GCC Code Coverage Report


Directory: ./
File: atmos_cubed_sphere/tools/test_cases.F90
Date: 2021-06-18 17:08:19
Exec Total Coverage
Lines: 0 3867 0.0%
Branches: 0 30251 0.0%

Line Branch Exec Source
1 !***********************************************************************
2 !* GNU Lesser General Public License
3 !*
4 !* This file is part of the FV3 dynamical core.
5 !*
6 !* The FV3 dynamical core is free software: you can redistribute it
7 !* and/or modify it under the terms of the
8 !* GNU Lesser General Public License as published by the
9 !* Free Software Foundation, either version 3 of the License, or
10 !* (at your option) any later version.
11 !*
12 !* The FV3 dynamical core is distributed in the hope that it will be
13 !* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
14 !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
15 !* See the GNU General Public License for more details.
16 !*
17 !* You should have received a copy of the GNU Lesser General Public
18 !* License along with the FV3 dynamical core.
19 !* If not, see <http://www.gnu.org/licenses/>.
20 !***********************************************************************
21
22 module test_cases_mod
23
24 ! <table>
25 ! <tr>
26 ! <th>Module Name</th>
27 ! <th>Functions Included</th>
28 ! </tr>
29 ! <tr>
30 ! <td>constants_mod</td>
31 ! <td>cnst_radius=>radius, pi=>pi_8, omega, grav, kappa, rdgas, cp_air, rvgas</td>
32 ! </tr>
33 ! <tr>
34 ! <td>diag_manager_mod</td>
35 ! <td>diag_axis_init, register_diag_field,
36 ! register_static_field, send_data, diag_grid_init</td>
37 ! </tr>
38 ! <tr>
39 ! <td>field_manager_mod</td>
40 ! <td>MODEL_ATMOS</td>
41 ! </tr>
42 ! <tr>
43 ! <td>fv_arrays_mod</td>
44 ! <td>fv_grid_type, fv_flags_type, fv_grid_bounds_type, R_GRID</td>
45 ! </tr>
46 ! <tr>
47 ! <td>fv_diagnostics_mod</td>
48 ! <td>prt_maxmin, ppme, eqv_pot, qcly0</td>
49 ! </tr>
50 ! <tr>
51 ! <td>fv_grid_tools_mod</td>
52 ! <td>todeg, missing, spherical_to_cartesian</td>
53 ! </tr>
54 ! <tr>
55 ! <td>fv_eta_mod</td>
56 ! <td>compute_dz_L32, compute_dz_L101, set_hybrid_z,
57 ! gw_1d,hybrid_z_dz</td>
58 ! </tr>
59 ! <tr>
60 ! <td>fv_mp_mod</td>
61 ! <td>ng, is_master,is,js,ie,je, isd,jsd,ied,jed,
62 ! domain_decomp, fill_corners, XDir, YDir, mp_stop,
63 ! mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst</td>
64 ! </tr>
65 ! <tr>
66 ! <td>fv_sg_mod</td>
67 ! <td>qsmith</td>
68 ! </tr>
69 ! <tr>
70 ! <td>fv_surf_map_mod</td>
71 ! <td>surfdrv</td>
72 ! </tr>
73 ! <tr>
74 ! <td>init_hydro_mod</td>
75 ! <td>p_var, hydro_eq</td>
76 ! </tr>
77 ! <tr>
78 ! <td>mpp_mod</td>
79 ! <td>mpp_error, FATAL, mpp_root_pe, mpp_broadcast, mpp_sum,
80 ! mpp_pe, mpp_chksum, stdout</td>
81 ! </tr>
82 ! <tr>
83 ! <td>mpp_domains_mod</td>
84 ! <td>mpp_update_domains, domain2d</td>
85 ! </tr>>
86 ! <tr>
87 ! <td>mpp_parameter_mod</td>
88 ! <td>AGRID_PARAM=>AGRID,CGRID_NE_PARAM=>CGRID_NE,SCALAR_PAIR</td>
89 ! </tr>
90 ! <tr>
91 ! <td>time_manager_mod</td>
92 ! <td>time_type, get_date, get_time</td>
93 ! </tr>
94 ! <tr>
95 ! <td>tracer_manager_mod</td>
96 ! <td>get_tracer_index</td>
97 ! </tr>
98 ! </table>
99
100 use constants_mod, only: cnst_radius=>radius, pi=>pi_8, omega, grav, kappa, rdgas, cp_air, rvgas
101 use init_hydro_mod, only: p_var, hydro_eq
102 use fv_mp_mod, only: ng, is_master, &
103 is,js,ie,je, isd,jsd,ied,jed, &
104 domain_decomp, fill_corners, XDir, YDir, &
105 mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst
106 use fv_grid_utils_mod, only: cubed_to_latlon, great_circle_dist, mid_pt_sphere, &
107 ptop_min, inner_prod, get_latlon_vector, get_unit_vect2, &
108 g_sum, latlon2xyz, cart_to_latlon, make_eta_level, f_p, project_sphere_v
109 use fv_surf_map_mod, only: surfdrv
110
111 use fv_grid_tools_mod, only: todeg, missing, spherical_to_cartesian
112 use fv_eta_mod, only: compute_dz_L32, compute_dz_L101, set_hybrid_z, gw_1d, &
113 hybrid_z_dz
114
115 use mpp_mod, only: mpp_error, FATAL, mpp_root_pe, mpp_broadcast, mpp_sum
116 use mpp_domains_mod, only: mpp_update_domains, domain2d
117 use mpp_parameter_mod, only: AGRID_PARAM=>AGRID,CGRID_NE_PARAM=>CGRID_NE, &
118 SCALAR_PAIR
119 use fv_sg_mod, only: qsmith
120 use fv_diagnostics_mod, only: prt_maxmin, ppme, eqv_pot, qcly0
121 !!! DEBUG CODE
122 use mpp_mod, only: mpp_pe, mpp_chksum, stdout
123 !!! END DEBUG CODE
124 use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, R_GRID
125 use tracer_manager_mod, only: get_tracer_index
126 use field_manager_mod, only: MODEL_ATMOS
127 implicit none
128 private
129
130 ! Test Case Number
131 ! -1 = Divergence conservation test
132 ! 0 = Idealized non-linear deformational flow
133 ! 1 = Cosine Bell advection
134 ! 2 = Zonal geostrophically balanced flow
135 ! 3 = non-rotating potential flow
136 ! 4 = Tropical cyclones (merger of Rankine vortices)
137 ! 5 = Zonal geostrophically balanced flow over an isolated mountain
138 ! 6 = Rossby Wave number 4
139 ! 7 = Barotropic instability
140 ! ! 8 = Potential flow (as in 5 but no rotation and initially at rest)
141 ! 8 = "Soliton" propagation twin-vortex along equator
142 ! 9 = Polar vortex
143 ! 10 = hydrostatically balanced 3D test with idealized mountain
144 ! 11 = Use this for cold starting the climate model with USGS terrain
145 ! 12 = Jablonowski & Williamson Baroclinic test case (Steady State)
146 ! 13 = Jablonowski & Williamson Baroclinic test case Perturbation
147 ! -13 = DCMIP 2016 J&W BC Wave, with perturbation
148 ! 14 = Use this for cold starting the Aqua-planet model
149 ! 15 = Small Earth density current
150 ! 16 = 3D hydrostatic non-rotating Gravity waves
151 ! 17 = 3D hydrostatic rotating Inertial Gravity waves (case 6-3-0)
152 ! 18 = 3D mountain-induced Rossby wave
153 ! 19 = As in 15 but without rotation
154 ! 20 = 3D non-hydrostatic lee vortices; non-rotating (small planet)
155 ! 21 = 3D non-hydrostatic lee vortices; rotating (small planet)
156 ! 30 = Super-Cell storm, curved hodograph, centered at OKC, no rotation
157 ! 31 = Super-Cell storm, curved hodograph, centered at OKC, with rotation
158 ! 32 = Super-Cell storm, straight hodograph, centered at OKC, no rotation
159 ! 33 = HIWPP Schar mountain waves, Ridge mountain (M1)
160 ! 34 = HIWPP Schar mountain waves, Circular mountain (M2)
161 ! 35 = HIWPP Schar mountain waves, Circular mountain with shear (M3)
162 ! 36 = HIWPP Super_Cell; no perturbation
163 ! 37 = HIWPP Super_Cell; with the prescribed thermal
164 ! 44 = Lock-exchange on the sphere; atm at rest with no mountain
165 ! 45 = New test
166 ! 51 = 3D tracer advection (deformational nondivergent flow)
167 ! 55 = TC
168 ! 101 = 3D non-hydrostatic Large-Eddy-Simulation (LES) with hybrid_z IC
169
170 integer :: sphum, theta_d
171 real(kind=R_GRID), parameter :: radius = cnst_radius
172 real(kind=R_GRID), parameter :: one = 1.d0
173 integer :: test_case
174 logical :: bubble_do
175 real :: alpha
176 integer :: Nsolitons
177 real :: soliton_size = 750.e3, soliton_Umax = 50.
178
179 ! Case 0 parameters
180 real :: p0_c0 = 3.0
181 real :: rgamma = 5.0
182 real :: lat0 = pi/2.0 !< pi/4.8
183 real :: lon0 = 0.0 !<pi-0.8
184
185 ! pi_shift moves the initial location of the cosine bell for Case 1
186 real, parameter :: pi_shift = 0.0 !< 3.0*pi/4.
187
188 ! -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate
189 integer, parameter :: initWindsCase0 =-1
190 integer, parameter :: initWindsCase1 = 1
191 integer, parameter :: initWindsCase2 = 5
192 integer, parameter :: initWindsCase5 = 5
193 integer, parameter :: initWindsCase6 =-1
194 integer, parameter :: initWindsCase9 =-1
195
196 real, allocatable, dimension(:) :: pz0, zz0
197
198 integer :: tracer_test, wind_field
199
200 ! Ubar = initial wind speed parameter
201 real :: Ubar, Vbar
202 ! gh0 = initial surface height parameter
203 real :: gh0
204
205 ! case 9 parameters
206 real , allocatable :: case9_B(:,:)
207 real :: AofT(2)
208
209
210 ! Validating fields used in statistics
211 real , allocatable :: phi0(:,:,:) !< Validating Field
212 real , allocatable :: ua0(:,:,:) !< Validating U-Wind
213 real , allocatable :: va0(:,:,:) !< Validating V-Windfms_io_exit, get_tile_string, &
214
215 real , allocatable :: gh_table(:), lats_table(:)
216 logical :: gh_initialized = .false.
217
218 ! Initial Conservation statistics ; total mass ; enstrophy ; energy
219 real :: tmass_orig !< total mass
220 real :: tvort_orig !< enstrophy (integral of total vorticity)
221 real :: tener_orig !< energy
222
223 integer, parameter :: interpOrder = 1
224
225 public :: pz0, zz0
226 public :: test_case, bubble_do, alpha, tracer_test, wind_field, nsolitons, soliton_Umax, soliton_size
227 public :: init_case, get_stats, check_courant_numbers
228 #ifdef NCDF_OUTPUT
229 public :: output, output_ncdf
230 #endif
231 public :: case9_forcing1, case9_forcing2, case51_forcing
232 public :: init_double_periodic, init_latlon
233 public :: checker_tracers
234
235 INTERFACE mp_update_dwinds
236 MODULE PROCEDURE mp_update_dwinds_2d
237 MODULE PROCEDURE mp_update_dwinds_3d
238 END INTERFACE
239
240 contains
241
242 !-------------------------------------------------------------------------------
243 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
244 subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nregions, nested, gridstruct, domain, tile)
245 ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate
246
247 real , intent(INOUT) :: UBar
248 real , intent(INOUT) :: u(isd:ied ,jsd:jed+1)
249 real , intent(INOUT) :: v(isd:ied+1,jsd:jed )
250 real , intent(INOUT) :: uc(isd:ied+1,jsd:jed )
251 real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1)
252 real , intent(INOUT) :: ua(isd:ied ,jsd:jed )
253 real , intent(INOUT) :: va(isd:ied ,jsd:jed )
254 integer, intent(IN) :: defOnGrid
255 integer, intent(IN) :: npx, npy
256 integer, intent(IN) :: ng
257 integer, intent(IN) :: ndims
258 integer, intent(IN) :: nregions
259 logical, intent(IN) :: nested
260 type(fv_grid_type), intent(IN), target :: gridstruct
261 type(domain2d), intent(INOUT) :: domain
262 integer, intent(IN) :: tile
263
264 real(kind=R_GRID) :: p1(2), p2(2), p3(2), p4(2), pt(2)
265 real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3)
266
267 real :: dist, r, r0
268 integer :: i,j,k,n
269 real :: utmp, vtmp
270
271 real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2
272 integer :: is2, ie2, js2, je2
273
274 real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
275 real, pointer, dimension(:,:) :: area, rarea, fC, f0
276 real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
277 real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
278 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
279
280 logical, pointer :: cubed_sphere, latlon
281
282 logical, pointer :: have_south_pole, have_north_pole
283
284 integer, pointer :: ntiles_g
285 real, pointer :: acapN, acapS, globalarea
286
287 grid => gridstruct%grid_64
288 agrid=> gridstruct%agrid_64
289
290 area => gridstruct%area
291 rarea => gridstruct%rarea
292
293 fC => gridstruct%fC
294 f0 => gridstruct%f0
295
296 ee1 => gridstruct%ee1
297 ee2 => gridstruct%ee2
298 ew => gridstruct%ew
299 es => gridstruct%es
300 en1 => gridstruct%en1
301 en2 => gridstruct%en2
302
303 dx => gridstruct%dx
304 dy => gridstruct%dy
305 dxa => gridstruct%dxa
306 dya => gridstruct%dya
307 rdxa => gridstruct%rdxa
308 rdya => gridstruct%rdya
309 dxc => gridstruct%dxc
310 dyc => gridstruct%dyc
311
312 cubed_sphere => gridstruct%cubed_sphere
313 latlon => gridstruct%latlon
314
315 have_south_pole => gridstruct%have_south_pole
316 have_north_pole => gridstruct%have_north_pole
317
318 ntiles_g => gridstruct%ntiles_g
319 acapN => gridstruct%acapN
320 acapS => gridstruct%acapS
321 globalarea => gridstruct%globalarea
322
323 if (nested) then
324
325 is2 = is-2
326 ie2 = ie+2
327 js2 = js-2
328 je2 = je+2
329
330 else
331
332 is2 = is
333 ie2 = ie
334 js2 = js
335 je2 = je
336
337 end if
338
339 200 format(i4.4,'x',i4.4,'x',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
340
341 psi(:,:) = 1.e25
342 psi_b(:,:) = 1.e25
343 do j=jsd,jed
344 do i=isd,ied
345 psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
346 cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
347 enddo
348 enddo
349 call mpp_update_domains( psi, domain )
350 do j=jsd,jed+1
351 do i=isd,ied+1
352 psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
353 cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
354 enddo
355 enddo
356
357 if ( (cubed_sphere) .and. (defOnGrid==0) ) then
358 do j=js,je+1
359 do i=is,ie
360 dist = dx(i,j)
361 vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
362 if (dist==0) vc(i,j) = 0.
363 enddo
364 enddo
365 do j=js,je
366 do i=is,ie+1
367 dist = dy(i,j)
368 uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
369 if (dist==0) uc(i,j) = 0.
370 enddo
371 enddo
372 call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
373 call fill_corners(uc, vc, npx, npy, VECTOR=.true., CGRID=.true.)
374 do j=js,je
375 do i=is,ie+1
376 dist = dxc(i,j)
377 v(i,j) = (psi(i,j)-psi(i-1,j))/dist
378 if (dist==0) v(i,j) = 0.
379 enddo
380 enddo
381 do j=js,je+1
382 do i=is,ie
383 dist = dyc(i,j)
384 u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
385 if (dist==0) u(i,j) = 0.
386 enddo
387 enddo
388 call mp_update_dwinds(u, v, npx, npy, domain)
389 do j=js,je
390 do i=is,ie
391 psi1 = 0.5*(psi(i,j)+psi(i,j-1))
392 psi2 = 0.5*(psi(i,j)+psi(i,j+1))
393 dist = dya(i,j)
394 ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
395 if (dist==0) ua(i,j) = 0.
396 psi1 = 0.5*(psi(i,j)+psi(i-1,j))
397 psi2 = 0.5*(psi(i,j)+psi(i+1,j))
398 dist = dxa(i,j)
399 va(i,j) = (psi2 - psi1) / (dist)
400 if (dist==0) va(i,j) = 0.
401 enddo
402 enddo
403
404 elseif ( (cubed_sphere) .and. (defOnGrid==1) ) then
405 do j=js,je+1
406 do i=is,ie
407 dist = dx(i,j)
408 vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
409 if (dist==0) vc(i,j) = 0.
410 enddo
411 enddo
412 do j=js,je
413 do i=is,ie+1
414 dist = dy(i,j)
415 uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
416 if (dist==0) uc(i,j) = 0.
417 enddo
418 enddo
419 call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
420 call fill_corners(uc, vc, npx, npy, VECTOR=.true., CGRID=.true.)
421 call ctoa(uc,vc,ua,va,dx, dy, dxc,dyc,dxa,dya,npx,npy,ng)
422 call atod(ua,va,u ,v ,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
423 ! call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd),v(isd,jsd), &
424 ! ua(isd,jsd),va(isd,jsd), uc(isd,jsd),vc(isd,jsd))
425 elseif ( (cubed_sphere) .and. (defOnGrid==2) ) then
426 do j=js2,je2
427 do i=is2,ie2+1
428 dist = dxc(i,j)
429 v(i,j) = (psi(i,j)-psi(i-1,j))/dist
430 if (dist==0) v(i,j) = 0.
431 enddo
432 enddo
433 do j=js2,je2+1
434 do i=is2,ie2
435 dist = dyc(i,j)
436 u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
437 if (dist==0) u(i,j) = 0.
438 enddo
439 enddo
440 call mp_update_dwinds(u, v, npx, npy, domain)
441 call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
442 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
443 elseif ( (cubed_sphere) .and. (defOnGrid==3) ) then
444 do j=js,je
445 do i=is,ie
446 psi1 = 0.5*(psi(i,j)+psi(i,j-1))
447 psi2 = 0.5*(psi(i,j)+psi(i,j+1))
448 dist = dya(i,j)
449 ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
450 if (dist==0) ua(i,j) = 0.
451 psi1 = 0.5*(psi(i,j)+psi(i-1,j))
452 psi2 = 0.5*(psi(i,j)+psi(i+1,j))
453 dist = dxa(i,j)
454 va(i,j) = (psi2 - psi1) / (dist)
455 if (dist==0) va(i,j) = 0.
456 enddo
457 enddo
458 call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
459 call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
460 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested,domain)
461 elseif ( (latlon) .or. (defOnGrid==4) ) then
462
463 do j=js,je
464 do i=is,ie
465 ua(i,j) = Ubar * ( COS(agrid(i,j,2))*COS(alpha) + &
466 SIN(agrid(i,j,2))*COS(agrid(i,j,1))*SIN(alpha) )
467 va(i,j) = -Ubar * SIN(agrid(i,j,1))*SIN(alpha)
468 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
469 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
470 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
471 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
472 if (cubed_sphere) call rotate_winds(ua(i,j), va(i,j), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
473
474 psi1 = 0.5*(psi(i,j)+psi(i,j-1))
475 psi2 = 0.5*(psi(i,j)+psi(i,j+1))
476 dist = dya(i,j)
477 if ( (tile==1) .and.(i==1) ) print*, ua(i,j), -1.0 * (psi2 - psi1) / (dist)
478
479 enddo
480 enddo
481 call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
482 call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
483 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
484 elseif ( (latlon) .or. (defOnGrid==5) ) then
485 ! SJL mods:
486 ! v-wind:
487 do j=js2,je2
488 do i=is2,ie2+1
489 p1(:) = grid(i ,j ,1:2)
490 p2(:) = grid(i,j+1 ,1:2)
491 call mid_pt_sphere(p1, p2, pt)
492 call get_unit_vect2 (p1, p2, e2)
493 call get_latlon_vector(pt, ex, ey)
494 utmp = Ubar * ( COS(pt(2))*COS(alpha) + &
495 SIN(pt(2))*COS(pt(1))*SIN(alpha) )
496 vtmp = -Ubar * SIN(pt(1))*SIN(alpha)
497 v(i,j) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
498 enddo
499 enddo
500 ! D grid u-wind:
501 do j=js2,je2+1
502 do i=is2,ie2
503 p1(:) = grid(i ,j ,1:2)
504 p2(:) = grid(i+1,j ,1:2)
505 call mid_pt_sphere(p1, p2, pt)
506 call get_unit_vect2 (p1, p2, e1)
507 call get_latlon_vector(pt, ex, ey)
508 utmp = Ubar * ( COS(pt(2))*COS(alpha) + &
509 SIN(pt(2))*COS(pt(1))*SIN(alpha) )
510 vtmp = -Ubar * SIN(pt(1))*SIN(alpha)
511 u(i,j) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
512 enddo
513 enddo
514
515 call mp_update_dwinds(u, v, npx, npy, domain)
516 call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
517 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
518 else
519 !print*, 'Choose an appropriate grid to define the winds on'
520 !stop
521 endif
522
523 end subroutine init_winds
524 !
525 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
526 !-------------------------------------------------------------------------------
527
528 !-------------------------------------------------------------------------------
529 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
530 ! init_case :: initialize the Williamson test cases:
531 ! case 1 (2-D advection of a cosine bell)
532 ! case 2 (Steady State Zonal Geostrophic Flow)
533 ! case 5 (Steady State Zonal Geostrophic Flow over Mountain)
534 ! case 6 (Rossby Wave-4 Case)
535 ! case 9 (Stratospheric Vortex Breaking Case)
536 !
537 subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
538 gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, &
539 dry_mass, mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, adiabatic, &
540 ks, npx_global, ptop, domain_in, tile_in, bd)
541
542 type(fv_grid_bounds_type), intent(IN) :: bd
543 real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
544 real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
545 real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
546 real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
547 real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
548 real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
549
550 real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
551
552 real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
553 real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
554 real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
555 real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
556 real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
557
558 real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
559 real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
560 real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
561 real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
562 real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:)
563 real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
564
565 real , intent(inout) :: ak(npz+1)
566 real , intent(inout) :: bk(npz+1)
567
568 integer, intent(IN) :: npx, npy, npz
569 integer, intent(IN) :: ng, ncnst, nwat
570 integer, intent(IN) :: ndims
571 integer, intent(IN) :: nregions
572
573 real, intent(IN) :: dry_mass
574 logical, intent(IN) :: mountain
575 logical, intent(IN) :: moist_phys
576 logical, intent(IN) :: hydrostatic
577 logical, intent(IN) :: hybrid_z
578 logical, intent(IN) :: adiabatic
579 integer, intent(IN) :: ks
580
581 type(fv_grid_type), target :: gridstruct
582 type(fv_flags_type), target, intent(IN) :: flagstruct
583
584 integer, intent(IN) :: npx_global
585 integer, intent(IN), target :: tile_in
586 real, intent(INOUT) :: ptop
587
588 type(domain2d), intent(IN), target :: domain_in
589
590 real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
591 real :: tmp1(1 :npx ,1 :npy ,1:nregions)
592
593 real(kind=R_GRID) :: p0(2) ! Temporary Point
594 real(kind=R_GRID) :: p1(2) ! Temporary Point
595 real(kind=R_GRID) :: p2(2) ! Temporary Point
596 real(kind=R_GRID) :: p3(2) ! Temporary Point
597 real(kind=R_GRID) :: p4(2) ! Temporary Point
598 real(kind=R_GRID) :: pa(2) ! Temporary Point
599 real(kind=R_GRID) :: pb(2) ! Temporary Point
600 real(kind=R_GRID) :: pcen(2) ! Temporary Point
601 real(kind=R_GRID) :: e1(3), e2(3), e3(3), ex(3), ey(3)
602 real :: dist, r, r1, r2, r0, omg, A, B, C
603 integer :: i,j,k,nreg,z,zz
604 integer :: i0,j0,n0, nt
605 real :: utmp,vtmp,ftmp
606 real :: rk
607
608 integer, parameter :: jm = 5761
609 real :: ll_phi(jm)
610 real :: ll_u(jm)
611 real :: ll_j(jm)
612 real :: cose(jm)
613 real :: sine(jm)
614 real :: cosp(jm)
615 real :: ddeg, deg, DDP, DP, ph5
616 real :: myB, myC, yy
617 integer :: jj,jm1
618
619 real :: Vtx, p, w_p
620 real :: x1,y1,z1,x2,y2,z2,ang
621
622 integer :: initWindsCase
623
624 real :: dummy
625 real :: ftop
626 real :: v1,v2
627 real :: m=1
628 real :: n=1
629 real :: L1_norm
630 real :: L2_norm
631 real :: Linf_norm
632 real :: pmin, pmin1
633 real :: pmax, pmax1
634 real :: grad(bd%isd:bd%ied ,bd%jsd:bd%jed,2)
635 real :: div0(bd%isd:bd%ied ,bd%jsd:bd%jed )
636 real :: vor0(bd%isd:bd%ied ,bd%jsd:bd%jed )
637 real :: divg(bd%isd:bd%ied ,bd%jsd:bd%jed )
638 real :: vort(bd%isd:bd%ied ,bd%jsd:bd%jed )
639 real :: ztop, rgrav, p00, pturb, zmid, pk0, t00
640 real :: dz1(npz), ppt(npz)
641 real :: ze1(npz+1), pe1(npz+1)
642
643 integer :: nlon,nlat
644 character(len=80) :: oflnm, hgtflnm
645 integer :: is2, ie2, js2, je2
646
647 real :: psi(bd%isd:bd%ied,bd%jsd:bd%jed)
648 real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1)
649 real :: psi1, psi2
650
651 ! Baroclinic Test Case 12
652 real :: eta(npz), eta_0, eta_s, eta_t
653 real :: eta_v(npz), press, anti_rot
654 real :: T_0, T_mean, delta_T, lapse_rate, n2, zeta, s0
655 real :: pt1,pt2,pt3,pt4,pt5,pt6, pt7, pt8, pt9, u1, pt0
656 real :: uu1, uu2, uu3, vv1, vv2, vv3
657 ! real wbuffer(npx+1,npz)
658 ! real sbuffer(npy+1,npz)
659 real wbuffer(npy+2,npz)
660 real sbuffer(npx+2,npz)
661
662 real :: gz(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1), zt, zdist
663 real :: zvir
664
665 integer :: Cl, Cl2
666
667 ! Super-Cell
668 real :: us0 = 30.
669 real, dimension(npz):: pk1, ts1, qs1, uz1, zs1, dudz
670 real:: zm, zc
671 real(kind=R_GRID):: pp0(2) ! center position
672
673 !Test case 35
674 real:: cs_m3
675 !Test case 51
676 real :: omega0, k_cell, z0, H, px
677 real :: d1, d2, p1p(2), rt, s
678 real :: wind_alpha, period, h0, rm, zp3(3), dz3(3), k0, lp
679
680
681 !Test case 55
682 real, dimension(npz+1) :: pe0, gz0, ue, ve, we, pte, qe
683 real :: d, cor, exppr, exppz, gamma, Ts0, q00, exponent, ztrop, height, zp, rp
684 real :: qtrop, ttrop, zq1, zq2
685 real :: dum, dum1, dum2, dum3, dum4, dum5, dum6, ptmp, uetmp, vetmp
686 real :: pe_u(bd%is:bd%ie,npz+1,bd%js:bd%je+1)
687 real :: pe_v(bd%is:bd%ie+1,npz+1,bd%js:bd%je)
688 real :: ps_u(bd%is:bd%ie,bd%js:bd%je+1)
689 real :: ps_v(bd%is:bd%ie+1,bd%js:bd%je)
690
691
692 real :: dz, zetam
693
694 real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
695 real(kind=R_GRID), pointer, dimension(:,:) :: area
696 real, pointer, dimension(:,:) :: rarea, fC, f0
697 real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
698 real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
699 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
700
701 logical, pointer :: cubed_sphere, latlon
702
703 type(domain2d), pointer :: domain
704 integer, pointer :: tile
705
706 logical, pointer :: have_south_pole, have_north_pole
707
708 integer, pointer :: ntiles_g
709 real, pointer :: acapN, acapS, globalarea
710
711 is = bd%is
712 ie = bd%ie
713 js = bd%js
714 je = bd%je
715 isd = bd%isd
716 ied = bd%ied
717 jsd = bd%jsd
718 jed = bd%jed
719
720 grid => gridstruct%grid_64
721 agrid=> gridstruct%agrid_64
722
723 area => gridstruct%area_64
724 rarea => gridstruct%rarea
725
726 fC => gridstruct%fC
727 f0 => gridstruct%f0
728
729 ee1 => gridstruct%ee1
730 ee2 => gridstruct%ee2
731 ew => gridstruct%ew
732 es => gridstruct%es
733 en1 => gridstruct%en1
734 en2 => gridstruct%en2
735
736 dx => gridstruct%dx
737 dy => gridstruct%dy
738 dxa => gridstruct%dxa
739 dya => gridstruct%dya
740 rdxa => gridstruct%rdxa
741 rdya => gridstruct%rdya
742 dxc => gridstruct%dxc
743 dyc => gridstruct%dyc
744
745 cubed_sphere => gridstruct%cubed_sphere
746 latlon => gridstruct%latlon
747
748 domain => domain_in
749 tile => tile_in
750
751 have_south_pole => gridstruct%have_south_pole
752 have_north_pole => gridstruct%have_north_pole
753
754 ntiles_g => gridstruct%ntiles_g
755 acapN => gridstruct%acapN
756 acapS => gridstruct%acapS
757 globalarea => gridstruct%globalarea
758
759 if (gridstruct%nested) then
760 is2 = isd
761 ie2 = ied
762 js2 = jsd
763 je2 = jed
764 else
765 is2 = is
766 ie2 = ie
767 js2 = js
768 je2 = je
769 end if
770
771 pe(:,:,:) = 0.0
772 pt(:,:,:) = 1.0
773 f0(:,:) = huge(dummy)
774 fC(:,:) = huge(dummy)
775 do j=jsd,jed+1
776 do i=isd,ied+1
777 fC(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
778 sin(grid(i,j,2))*cos(alpha) )
779 enddo
780 enddo
781 do j=jsd,jed
782 do i=isd,ied
783 f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
784 sin(agrid(i,j,2))*cos(alpha) )
785 enddo
786 enddo
787 call mpp_update_domains( f0, domain )
788 if (cubed_sphere) call fill_corners(f0, npx, npy, YDir)
789
790 delp(isd:is-1,jsd:js-1,1:npz)=0.
791 delp(isd:is-1,je+1:jed,1:npz)=0.
792 delp(ie+1:ied,jsd:js-1,1:npz)=0.
793 delp(ie+1:ied,je+1:jed,1:npz)=0.
794
795 #if defined(SW_DYNAMICS)
796 select case (test_case)
797 case(-2)
798 case(-1)
799 Ubar = (2.0*pi*radius)/(12.0*86400.0)
800 gh0 = 2.94e4
801 phis = 0.0
802 do j=js,je
803 do i=is,ie
804 delp(i,j,1) = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
805 ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
806 sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
807 enddo
808 enddo
809 call init_winds(UBar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
810
811 ! Test Divergence operator at cell centers
812 do j=js,je
813 do i=is,ie
814 divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
815 (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
816 if ( (tile==1) .and. (i==1) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
817 enddo
818 enddo
819 ! Test Vorticity operator at cell centers
820 do j=js,je
821 do i=is,ie
822 vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
823 (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
824 enddo
825 enddo
826 div0(:,:) = 1.e-20
827 ! call mpp_update_domains( div0, domain )
828 ! call mpp_update_domains( vor0, domain )
829 ! call mpp_update_domains( divg, domain )
830 ! call mpp_update_domains( vort, domain )
831 call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
832 pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
833 200 format(i4.4,'x',i4.4,'x',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
834 201 format(' ',A,e21.14,' ',e21.14)
835 202 format(' ',A,i4.4,'x',i4.4,'x',i4.4)
836 if ( is_master() ) then
837 write(*,*) ' Error Norms of Analytical Divergence field C-Winds initialized'
838 write(*,201) 'Divergence MAX error : ', pmax
839 write(*,201) 'Divergence MIN error : ', pmin
840 write(*,201) 'Divergence L1_norm : ', L1_norm
841 write(*,201) 'Divergence L2_norm : ', L2_norm
842 write(*,201) 'Divergence Linf_norm : ', Linf_norm
843 endif
844
845 call init_winds(UBar, u,v,ua,va,uc,vc, 3, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
846 ! Test Divergence operator at cell centers
847 do j=js,je
848 do i=is,ie
849 divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
850 (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
851 if ( (tile==1) .and. (i==1) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
852 enddo
853 enddo
854 ! Test Vorticity operator at cell centers
855 do j=js,je
856 do i=is,ie
857 vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
858 (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
859 enddo
860 enddo
861 ua0 = ua
862 va0 = va
863 div0(:,:) = 1.e-20
864 call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
865 pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
866 if ( is_master() ) then
867 write(*,*) ' Error Norms of Analytical Divergence field A-Winds initialized'
868 write(*,201) 'Divergence MAX error : ', pmax
869 write(*,201) 'Divergence MIN error : ', pmin
870 write(*,201) 'Divergence L1_norm : ', L1_norm
871 write(*,201) 'Divergence L2_norm : ', L2_norm
872 write(*,201) 'Divergence Linf_norm : ', Linf_norm
873 endif
874
875 call init_winds(UBar, u,v,ua,va,uc,vc, 2, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
876 !call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd,1),v(isd,jsd,1), &
877 ! ua(isd,jsd,1),va(isd,jsd,1), uc(isd,jsd,1),vc(isd,jsd,1))
878 ! Test Divergence operator at cell centers
879 do j=js,je
880 do i=is,ie
881 divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
882 (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
883 if ( (tile==1) .and. ((i==1) .or.(i==npx-1)) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
884 enddo
885 enddo
886 ! Test Vorticity operator at cell centers
887 do j=js,je
888 do i=is,ie
889 vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
890 (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
891 enddo
892 enddo
893 div0(:,:) = 1.e-20
894 call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
895 pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
896 if ( is_master() ) then
897 write(*,*) ' Error Norms of Analytical Divergence field D-Winds initialized'
898 write(*,201) 'Divergence MAX error : ', pmax
899 write(*,201) 'Divergence MIN error : ', pmin
900 write(*,201) 'Divergence L1_norm : ', L1_norm
901 write(*,201) 'Divergence L2_norm : ', L2_norm
902 write(*,201) 'Divergence Linf_norm : ', Linf_norm
903 endif
904
905 call mp_stop()
906 stop
907 case(0)
908 do j=jsd,jed
909 do i=isd,ied
910
911 x1 = agrid(i,j,1)
912 y1 = agrid(i,j,2)
913 z1 = radius
914
915 p = p0_c0 * cos(y1)
916 Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
917 w_p = 0.0
918 if (p /= 0.0) w_p = Vtx/p
919 delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*0.0) )
920 ua(i,j,1) = w_p*(sin(lat0)*cos(agrid(i,j,2)) + cos(lat0)*cos(agrid(i,j,1) - lon0)*sin(agrid(i,j,2)))
921 va(i,j,1) = w_p*cos(lat0)*sin(agrid(i,j,1) - lon0)
922 ua(i,j,1) = ua(i,j,1)*radius/86400.0
923 va(i,j,1) = va(i,j,1)*radius/86400.0
924
925 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
926 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
927 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
928 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
929 if (cubed_sphere) call rotate_winds(ua(i,j,1),va(i,j,1), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
930
931 enddo
932 enddo
933 call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
934 call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain)
935 call mp_update_dwinds(u, v, npx, npy, npz, domain)
936 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
937 call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
938 call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.)
939 initWindsCase=initWindsCase0
940 case(1)
941 Ubar = (2.0*pi*radius)/(12.0*86400.0)
942 gh0 = 1.0
943 phis = 0.0
944 r0 = radius/3. !RADIUS radius/3.
945 p1(1) = pi/2. + pi_shift
946 p1(2) = 0.
947 do j=jsd,jed
948 do i=isd,ied
949 p2(1) = agrid(i,j,1)
950 p2(2) = agrid(i,j,2)
951 r = great_circle_dist( p1, p2, radius )
952 if (r < r0) then
953 delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
954 else
955 delp(i,j,1) = phis(i,j)
956 endif
957 enddo
958 enddo
959 initWindsCase=initWindsCase1
960 case(2)
961 #ifdef TEST_TRACER
962 !!$ do j=js2,je2
963 !!$ do i=is2,ie2
964 !!$ q(i,j,1,:) = 1.e-3*cos(agrid(i,j,2))!*(1.+cos(agrid(i,j,1)))
965 !!$ enddo
966 !!$ enddo
967 gh0 = 1.0e-6
968 r0 = radius/3. !RADIUS radius/3.
969 p1(2) = 35./180.*pi !0.
970 p1(1) = pi/4.!pi/2.
971 do j=jsd,jed
972 do i=isd,ied
973 p2(1) = agrid(i,j,1)
974 p2(2) = agrid(i,j,2)
975 r = great_circle_dist( p1, p2, radius )
976 if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.)) then
977 !q(i,j,k,1) = max(gh0*0.5*(1.0+cos(PI*r/r0))*exp(real(k-npz)),0.)
978 q(i,j,1,1) = gh0
979 else
980 q(i,j,1,1) = 0.
981 endif
982 enddo
983 enddo
984 #endif
985 Ubar = (2.0*pi*radius)/(12.0*86400.0)
986 gh0 = 2.94e4
987 phis = 0.0
988 do j=js2,je2
989 do i=is2,ie2
990 ! do j=jsd,jed
991 ! do i=isd,ied
992 #ifdef FIVE_AVG
993 pt5 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
994 ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
995 sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
996 pt1 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
997 ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
998 sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0
999 pt2 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
1000 ( -1.*cos(grid(i+1,j ,1))*cos(grid(i+1,j ,2))*sin(alpha) + &
1001 sin(grid(i+1,j ,2))*cos(alpha) ) ** 2.0
1002 pt3 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
1003 ( -1.*cos(grid(i+1,j+1,1))*cos(grid(i+1,j+1,2))*sin(alpha) + &
1004 sin(grid(i+1,j+1,2))*cos(alpha) ) ** 2.0
1005 pt4 = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
1006 ( -1.*cos(grid(i,j+1,1))*cos(grid(i,j+1,2))*sin(alpha) + &
1007 sin(grid(i,j+1,2))*cos(alpha) ) ** 2.0
1008 delp(i,j,1) = (0.25*(pt1+pt2+pt3+pt4) + 3.*pt5) / 4.
1009 #else
1010 delp(i,j,1) = gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
1011 ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1012 sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
1013 #endif
1014 enddo
1015 enddo
1016 initWindsCase=initWindsCase2
1017 case(3)
1018 !----------------------------
1019 ! Non-rotating potential flow
1020 !----------------------------
1021 #ifdef NO_WIND
1022 ubar = 0.
1023 #else
1024 ubar = 40.
1025 #endif
1026 gh0 = 1.0e3 * grav
1027 phis = 0.0
1028 r0 = radius/3. !RADIUS radius/3.
1029 p1(1) = pi*1.5
1030 p1(2) = 0.
1031 do j=jsd,jed
1032 do i=isd,ied
1033 p2(1) = agrid(i,j,1)
1034 p2(2) = agrid(i,j,2)
1035 r = great_circle_dist( p1, p2, radius )
1036 if (r < r0) then
1037 delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
1038 else
1039 delp(i,j,1) = phis(i,j)
1040 endif
1041 ! Add a constant:
1042 delp(i,j,1) = delp(i,j,1) + grav*2.e3
1043 enddo
1044 enddo
1045
1046 #ifdef NO_WIND
1047 u = 0.; v = 0.
1048 f0 = 0.; fC = 0.
1049 #else
1050
1051 do j=js,je
1052 do i=is,ie+1
1053 p1(:) = grid(i ,j ,1:2)
1054 p2(:) = grid(i,j+1 ,1:2)
1055 call mid_pt_sphere(p1, p2, p3)
1056 call get_unit_vect2(p1, p2, e2)
1057 call get_latlon_vector(p3, ex, ey)
1058 utmp = ubar * cos(p3(2))
1059 vtmp = 0.
1060 v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
1061 enddo
1062 enddo
1063 do j=js,je+1
1064 do i=is,ie
1065 p1(:) = grid(i, j,1:2)
1066 p2(:) = grid(i+1,j,1:2)
1067 call mid_pt_sphere(p1, p2, p3)
1068 call get_unit_vect2(p1, p2, e1)
1069 call get_latlon_vector(p3, ex, ey)
1070 utmp = ubar * cos(p3(2))
1071 vtmp = 0.
1072 u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1073 enddo
1074 enddo
1075
1076 anti_rot = -ubar/ radius
1077 do j=jsd,jed+1
1078 do i=isd,ied+1
1079 fC(i,j) = 2.*anti_rot*sin(grid(i,j,2))
1080 enddo
1081 enddo
1082 do j=jsd,jed
1083 do i=isd,ied
1084 f0(i,j) = 2.*anti_rot*sin(agrid(i,j,2))
1085 enddo
1086 enddo
1087 #endif
1088 initWindsCase= -1
1089
1090 case(4)
1091
1092 !----------------------------
1093 ! Tropical cyclones
1094 !----------------------------
1095 ! f0 = 0.; fC = 0. ! non-rotating planet setup
1096 u = 0.
1097 v = 0.
1098 phis = 0.0 ! flat terrain
1099
1100 ubar = 50. ! maxmium wind speed (m/s)
1101 r0 = 250.e3 ! RADIUS of the maximum wind of the Rankine vortex
1102 gh0 = grav * 1.e3
1103
1104 do j=jsd,jed
1105 do i=isd,ied
1106 delp(i,j,1) = gh0
1107 enddo
1108 enddo
1109
1110 ! ddeg = 2.*r0/radius ! no merger
1111 ddeg = 1.80*r0/radius ! merged
1112
1113 p1(1) = pi*1.5 - ddeg
1114 p1(2) = pi/18. ! 10 N
1115 call rankine_vortex(ubar, r0, p1, u, v, grid)
1116
1117 p2(1) = pi*1.5 + ddeg
1118 p2(2) = pi/18. ! 10 N
1119 call rankine_vortex(ubar, r0, p2, u, v, grid)
1120
1121 #ifndef SINGULAR_VORTEX
1122 !-----------
1123 ! Anti-pole:
1124 !-----------
1125 ubar = -ubar
1126 call latlon2xyz(p1, e1)
1127 do i=1,3
1128 e1(i) = -e1(i)
1129 enddo
1130 call cart_to_latlon(1, e1, p3(1), p3(2))
1131 call rankine_vortex(ubar, r0, p3, u, v, grid)
1132
1133 call latlon2xyz(p2, e1)
1134 do i=1,3
1135 e1(i) = -e1(i)
1136 enddo
1137 call cart_to_latlon(1, e1, p4(1), p4(2))
1138 call rankine_vortex(ubar, r0, p4, u, v, grid)
1139 #endif
1140 call mp_update_dwinds(u, v, npx, npy, npz, domain)
1141 initWindsCase=-1 ! do nothing
1142
1143 case(5)
1144
1145 Ubar = 20.
1146 gh0 = 5960.*Grav
1147 phis = 0.0
1148 r0 = PI/9.
1149 p1(1) = PI/2.
1150 p1(2) = PI/6.
1151 do j=js2,je2
1152 do i=is2,ie2
1153 p2(1) = agrid(i,j,1)
1154 p2(2) = agrid(i,j,2)
1155 r = MIN(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1156 r = SQRT(r)
1157 phis(i,j) = 2000.0*Grav*(1.0-(r/r0))
1158 enddo
1159 enddo
1160 do j=js2,je2
1161 do i=is2,ie2
1162 delp(i,j,1) =gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
1163 ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1164 sin(agrid(i ,j ,2))*cos(alpha) ) ** 2 - phis(i,j)
1165 enddo
1166 enddo
1167 initWindsCase=initWindsCase5
1168 case(6)
1169 gh0 = 8.E3*Grav
1170 R = 4.
1171 omg = 7.848E-6
1172 rk = 7.848E-6
1173 phis = 0.0
1174 do j=js,je
1175 do i=is,ie
1176 A = 0.5*omg*(2.*omega+omg)*(COS(agrid(i,j,2))**2) + &
1177 0.25*rk*rk*(COS(agrid(i,j,2))**(r+r)) * &
1178 ( (r+1)*(COS(agrid(i,j,2))**2) + (2.*r*r-r-2.) - &
1179 2.*(r*r)*COS(agrid(i,j,2))**(-2.) )
1180 B = (2.*(omega+omg)*rk / ((r+1)*(r+2))) * (COS(agrid(i,j,2))**r) * &
1181 ( (r*r+2.*r+2.) - ((r+1.)*COS(agrid(i,j,2)))**2 )
1182 C = 0.25*rk*rk*(COS(agrid(i,j,2))**(2.*r)) * ( &
1183 (r+1) * (COS(agrid(i,j,2))**2.) - (r+2.) )
1184 delp(i,j,1) =gh0 + radius*radius*(A+B*COS(r*agrid(i,j,1))+C*COS(2.*r*agrid(i,j,1)))
1185 delp(i,j,1) = delp(i,j,1) - phis(i,j)
1186 enddo
1187 enddo
1188 do j=js,je
1189 do i=is,ie+1
1190 p1(:) = grid(i ,j ,1:2)
1191 p2(:) = grid(i,j+1 ,1:2)
1192 call mid_pt_sphere(p1, p2, p3)
1193 call get_unit_vect2(p1, p2, e2)
1194 call get_latlon_vector(p3, ex, ey)
1195 utmp = radius*omg*cos(p3(2)) + &
1196 radius*rk*(cos(p3(2))**(R-1))*(R*sin(p3(2))**2-cos(p3(2))**2)*cos(R*p3(1))
1197 vtmp = -radius*rk*R*sin(p3(2))*sin(R*p3(1))*cos(p3(2))**(R-1)
1198 v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
1199 enddo
1200 enddo
1201 do j=js,je+1
1202 do i=is,ie
1203 p1(:) = grid(i, j,1:2)
1204 p2(:) = grid(i+1,j,1:2)
1205 call mid_pt_sphere(p1, p2, p3)
1206 call get_unit_vect2(p1, p2, e1)
1207 call get_latlon_vector(p3, ex, ey)
1208 utmp = radius*omg*cos(p3(2)) + &
1209 radius*rk*(cos(p3(2))**(R-1))*(R*sin(p3(2))**2-cos(p3(2))**2)*cos(R*p3(1))
1210 vtmp = -radius*rk*R*sin(p3(2))*sin(R*p3(1))*cos(p3(2))**(R-1)
1211 u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1212 enddo
1213 enddo
1214 call mp_update_dwinds(u, v, npx, npy, npz, domain)
1215 call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
1216 !call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
1217 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
1218 initWindsCase=initWindsCase6
1219 case(7)
1220 ! Barotropically unstable jet
1221 gh0 = 10.E3*Grav
1222 phis = 0.0
1223 r0 = radius/12.
1224 p2(1) = pi/2.
1225 p2(2) = pi/4.
1226 do j=js,je
1227 do i=is,ie
1228 ! ftmp = gh0
1229 ! 9-point average:
1230 ! 9 4 8
1231 !
1232 ! 5 1 3
1233 !
1234 ! 6 2 7
1235 pt1 = gh_jet(npy, agrid(i,j,2))
1236 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), pa)
1237 pt2 = gh_jet(npy, pa(2))
1238 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), pa)
1239 pt3 = gh_jet(npy, pa(2))
1240 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), pa)
1241 pt4 = gh_jet(npy, pa(2))
1242 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), pa)
1243 pt5 = gh_jet(npy, pa(2))
1244 pt6 = gh_jet(npy, grid(i, j, 2))
1245 pt7 = gh_jet(npy, grid(i+1,j, 2))
1246 pt8 = gh_jet(npy, grid(i+1,j+1,2))
1247 pt9 = gh_jet(npy, grid(i ,j+1,2))
1248 ftmp = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1249 #ifndef NEW_PERT
1250 delp(i,j,1) = ftmp + 120.*grav*cos(agrid(i,j,2)) * &
1251 exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1252 ! phis(i,j) = ftmp
1253 ! delp(i,j,1) = 10.E3*grav + 120.*grav*cos(agrid(i,j,2)) * &
1254 ! exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1255 #else
1256 ! Using great circle dist:
1257 p1(:) = agrid(i,j,1:2)
1258 delp(i,j,1) = ftmp
1259 r = great_circle_dist(p1, p2, radius)
1260 if ( r < 3.*r0 ) then
1261 delp(i,j,1) = delp(i,j,1) + 1000.*grav*exp(-(r/r0)**2)
1262 endif
1263 #endif
1264 enddo
1265 enddo
1266
1267 ! v-wind:
1268 do j=js,je
1269 do i=is,ie+1
1270 p2(:) = grid(i,j+1,1:2)
1271 vv1 = u_jet(p2(2))*(ee2(2,i,j+1)*cos(p2(1)) - ee2(1,i,j+1)*sin(p2(1)))
1272 p1(:) = grid(i,j,1:2)
1273 vv3 = u_jet(p1(2))*(ee2(2,i,j)*cos(p1(1)) - ee2(1,i,j)*sin(p1(1)))
1274 ! Mid-point:
1275 call mid_pt_sphere(p1, p2, pa)
1276 vv2 = u_jet(pa(2))*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1277 ! 3-point average:
1278 v(i,j,1) = 0.25*(vv1 + 2.*vv2 + vv3)
1279 ! v(i,j,1) = vv2
1280 enddo
1281 enddo
1282 ! U-wind:
1283 do j=js,je+1
1284 do i=is,ie
1285 p1(:) = grid(i,j,1:2)
1286 uu1 = u_jet(p1(2))*(ee1(2,i,j)*cos(p1(1)) - ee1(1,i,j)*sin(p1(1)))
1287 p2(:) = grid(i+1,j,1:2)
1288 uu3 = u_jet(p2(2))*(ee1(2,i+1,j)*cos(p2(1)) - ee1(1,i+1,j)*sin(p2(1)))
1289 ! Mid-point:
1290 call mid_pt_sphere(p1, p2, pa)
1291 uu2 = u_jet(pa(2))*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1292 ! 3-point average:
1293 u(i,j,1) = 0.25*(uu1 + 2.*uu2 + uu3)
1294 ! u(i,j,1) = uu2
1295 enddo
1296 enddo
1297 initWindsCase=initWindsCase6 ! shouldn't do anything with this
1298 !initialize tracer with shallow-water PV
1299 !Compute vorticity
1300 call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,1), dx, dy, rarea)
1301 do j=jsd,jed+1
1302 do i=isd,ied+1
1303 fC(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
1304 sin(grid(i,j,2))*cos(alpha) )
1305 enddo
1306 enddo
1307 do j=jsd,jed
1308 do i=isd,ied
1309 f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
1310 sin(agrid(i,j,2))*cos(alpha) )
1311 enddo
1312 enddo
1313 call mpp_update_domains( f0, domain )
1314 if (cubed_sphere) call fill_corners(f0, npx, npy, YDir)
1315 do j=js,je
1316 do i=is,ie
1317 q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) / delp(i,j,npz) * 1.e6 ! PVU
1318 !q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) * grav / delp(i,j,npz)
1319 enddo
1320 enddo
1321 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
1322
1323 case(8)
1324 #ifdef USE_OLD
1325 !----------------------------
1326 ! Non-rotating potential flow
1327 !----------------------------
1328 gh0 = 5960.*Grav
1329 phis = 0.0
1330 r0 = PI/9.
1331 p1(1) = PI/2.
1332 p1(2) = PI/6.
1333 do j=js,je
1334 do i=is,ie
1335 p2(1) = agrid(i,j,1)
1336 p2(2) = agrid(i,j,2)
1337 r = MIN(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1338 r = SQRT(r)
1339 phis(i,j) = 2000.0*Grav*(1.0-(r/r0))
1340 enddo
1341 enddo
1342 do j=js,je
1343 do i=is,ie
1344 delp(i,j,1) = gh0
1345 enddo
1346 enddo
1347 u = 0.; v = 0.
1348 f0 = 0.; fC = 0.
1349 initWindsCase= -1
1350 #endif
1351 !----------------------------
1352 ! Soliton twin-vortex
1353 !----------------------------
1354 if ( is_master() ) write(*,*) 'Initialzing case-8: soliton twin cycolne...'
1355 f0 = 0.; fC = 0. ! non-rotating planet setup
1356 phis = 0.0 ! flat terrain
1357 gh0 = 5.E3*Grav
1358 do j=js,je
1359 do i=is,ie
1360 delp(i,j,1) = gh0
1361 enddo
1362 enddo
1363
1364 ! Initiate the westerly-wind-burst:
1365 ubar = soliton_Umax
1366 r0 = soliton_size
1367 !!$ ubar = 200. ! maxmium wind speed (m/s)
1368 !!$ r0 = 250.e3
1369 !!$ ubar = 50. ! maxmium wind speed (m/s)
1370 !!$ r0 = 750.e3
1371 ! #1 1: westerly
1372 p0(1) = pi*0.5
1373 p0(2) = 0.
1374
1375 do j=js,je
1376 do i=is,ie+1
1377 p1(:) = grid(i ,j ,1:2)
1378 p2(:) = grid(i,j+1 ,1:2)
1379 call mid_pt_sphere(p1, p2, p3)
1380 r = great_circle_dist( p0, p3, radius )
1381 utmp = ubar*exp(-(r/r0)**2)
1382 call get_unit_vect2(p1, p2, e2)
1383 call get_latlon_vector(p3, ex, ey)
1384 v(i,j,1) = utmp*inner_prod(e2,ex)
1385 enddo
1386 enddo
1387 do j=js,je+1
1388 do i=is,ie
1389 p1(:) = grid(i, j,1:2)
1390 p2(:) = grid(i+1,j,1:2)
1391 call mid_pt_sphere(p1, p2, p3)
1392 r = great_circle_dist( p0, p3, radius )
1393 utmp = ubar*exp(-(r/r0)**2)
1394 call get_unit_vect2(p1, p2, e1)
1395 call get_latlon_vector(p3, ex, ey)
1396 u(i,j,1) = utmp*inner_prod(e1,ex)
1397 enddo
1398 enddo
1399
1400 ! #1 2: easterly
1401 p0(1) = p0(1) + pi
1402 p0(2) = 0.
1403
1404 do j=js,je
1405 do i=is,ie+1
1406 p1(:) = grid(i ,j ,1:2)
1407 p2(:) = grid(i,j+1 ,1:2)
1408 call mid_pt_sphere(p1, p2, p3)
1409 r = great_circle_dist( p0, p3, radius )
1410 utmp = ubar*exp(-(r/r0)**2)
1411 call get_unit_vect2(p1, p2, e2)
1412 call get_latlon_vector(p3, ex, ey)
1413 v(i,j,1) = v(i,j,1) - utmp*inner_prod(e2,ex)
1414 enddo
1415 enddo
1416 do j=js,je+1
1417 do i=is,ie
1418 p1(:) = grid(i, j,1:2)
1419 p2(:) = grid(i+1,j,1:2)
1420 call mid_pt_sphere(p1, p2, p3)
1421 r = great_circle_dist( p0, p3, radius )
1422 utmp = ubar*exp(-(r/r0)**2)
1423 call get_unit_vect2(p1, p2, e1)
1424 call get_latlon_vector(p3, ex, ey)
1425 u(i,j,1) = u(i,j,1) - utmp*inner_prod(e1,ex)
1426 enddo
1427 enddo
1428 initWindsCase= -1
1429
1430 case(9)
1431 #ifdef USE_OLD
1432 jm1 = jm - 1
1433 DDP = PI/DBLE(jm1)
1434 DP = DDP
1435 ll_j(1) = -0.5*PI
1436 do j=2,jm
1437 ph5 = -0.5*PI + (DBLE(j-1)-0.5)*DDP
1438 ll_j(j) = -0.5*PI + (DBLE(j-1)*DDP)
1439 sine(j) = SIN(ph5)
1440 enddo
1441 cosp( 1) = 0.
1442 cosp(jm) = 0.
1443 do j=2,jm1
1444 cosp(j) = (sine(j+1)-sine(j)) / DP
1445 enddo
1446 do j=2,jm
1447 cose(j) = 0.5 * (cosp(j-1) + cosp(j))
1448 enddo
1449 cose(1) = cose(2)
1450 ddeg = 180./float(jm-1)
1451 do j=2,jm
1452 deg = -90. + (float(j-1)-0.5)*ddeg
1453 if (deg <= 0.) then
1454 ll_u(j) = -10.*(deg+90.)/90.
1455 elseif (deg <= 60.) then
1456 ll_u(j) = -10. + deg
1457 else
1458 ll_u(j) = 50. - (50./30.)* (deg - 60.)
1459 endif
1460 enddo
1461 ll_phi(1) = 6000. * Grav
1462 do j=2,jm1
1463 ll_phi(j)=ll_phi(j-1) - DP*sine(j) * &
1464 (radius*2.*omega + ll_u(j)/cose(j))*ll_u(j)
1465 enddo
1466 phis = 0.0
1467 do j=js,je
1468 do i=is,ie
1469 do jj=1,jm1
1470 if ( (ll_j(jj) <= agrid(i,j,2)) .and. (agrid(i,j,2) <= ll_j(jj+1)) ) then
1471 delp(i,j,1)=0.5*(ll_phi(jj)+ll_phi(jj+1))
1472 endif
1473 enddo
1474 enddo
1475 enddo
1476
1477 do j=js,je
1478 do i=is,ie
1479 if (agrid(i,j,2)*todeg <= 0.0) then
1480 ua(i,j,1) = -10.*(agrid(i,j,2)*todeg + 90.)/90.
1481 elseif (agrid(i,j,2)*todeg <= 60.0) then
1482 ua(i,j,1) = -10. + agrid(i,j,2)*todeg
1483 else
1484 ua(i,j,1) = 50. - (50./30.)* (agrid(i,j,2)*todeg - 60.)
1485 endif
1486 va(i,j,1) = 0.0
1487 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1488 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
1489 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
1490 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
1491 if (cubed_sphere) call rotate_winds(ua(i,j,1), va(i,j,1), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
1492 enddo
1493 enddo
1494
1495 call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
1496 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
1497 call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
1498 call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.)
1499 call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain)
1500 call mp_update_dwinds(u, v, npx, npy, npz, domain)
1501 initWindsCase=initWindsCase9
1502
1503
1504 call get_case9_B(case9_B, agrid)
1505 AofT(:) = 0.0
1506 #else
1507 !----------------------------
1508 ! Soliton twin-vortex
1509 !----------------------------
1510 if ( is_master() ) write(*,*) 'Initialzing case-9: soliton cyclones...'
1511 f0 = 0.; fC = 0. ! non-rotating planet setup
1512 phis = 0.0 ! flat terrain
1513 gh0 = 5.E3*Grav
1514 do j=js,je
1515 do i=is,ie
1516 delp(i,j,1) = gh0
1517 enddo
1518 enddo
1519
1520 ! Initiate the westerly-wind-burst:
1521 ubar = soliton_Umax
1522 r0 = soliton_size
1523 !!$ ubar = 200. ! maxmium wind speed (m/s)
1524 !!$ r0 = 250.e3
1525 !!$ ubar = 50. ! maxmium wind speed (m/s)
1526 !!$ r0 = 750.e3
1527 p0(1) = pi*0.5
1528 p0(2) = 0.
1529
1530 do j=js,je
1531 do i=is,ie+1
1532 p1(:) = grid(i ,j ,1:2)
1533 p2(:) = grid(i,j+1 ,1:2)
1534 call mid_pt_sphere(p1, p2, p3)
1535 r = great_circle_dist( p0, p3, radius )
1536 utmp = ubar*exp(-(r/r0)**2)
1537 call get_unit_vect2(p1, p2, e2)
1538 call get_latlon_vector(p3, ex, ey)
1539 v(i,j,1) = utmp*inner_prod(e2,ex)
1540 enddo
1541 enddo
1542 do j=js,je+1
1543 do i=is,ie
1544 p1(:) = grid(i, j,1:2)
1545 p2(:) = grid(i+1,j,1:2)
1546 call mid_pt_sphere(p1, p2, p3)
1547 r = great_circle_dist( p0, p3, radius )
1548 utmp = ubar*exp(-(r/r0)**2)
1549 call get_unit_vect2(p1, p2, e1)
1550 call get_latlon_vector(p3, ex, ey)
1551 u(i,j,1) = utmp*inner_prod(e1,ex)
1552 enddo
1553 enddo
1554 initWindsCase= -1
1555 #endif
1556 end select
1557 !--------------- end s-w cases --------------------------
1558
1559 ! Copy 3D data for Shallow Water Tests
1560 do z=2,npz
1561 delp(:,:,z) = delp(:,:,1)
1562 enddo
1563
1564 call mpp_update_domains( delp, domain )
1565 call mpp_update_domains( phis, domain )
1566 phi0 = delp
1567
1568 call init_winds(UBar, u,v,ua,va,uc,vc, initWindsCase, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
1569 ! Copy 3D data for Shallow Water Tests
1570 do z=2,npz
1571 u(:,:,z) = u(:,:,1)
1572 v(:,:,z) = v(:,:,1)
1573 enddo
1574
1575 do j=js,je
1576 do i=is,ie
1577 ps(i,j) = delp(i,j,1)
1578 enddo
1579 enddo
1580 ! -------- end s-w section ----------------------------------
1581 #else
1582
1583 if (test_case==10 .or. test_case==14) then
1584
1585 alpha = 0.
1586
1587 ! Initialize dry atmosphere
1588 q(:,:,:,:) = 3.e-6
1589 u(:,:,:) = 0.0
1590 v(:,:,:) = 0.0
1591 if (.not.hydrostatic) w(:,:,:)= 0.0
1592
1593 if ( test_case==14 ) then
1594 ! Aqua-planet case: mean SLP=1.E5
1595 phis = 0.0
1596 call hydro_eq(npz, is, ie, js, je, ps, phis, 1.E5, &
1597 delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
1598 else
1599 ! Initialize topography
1600 gh0 = 5960.*Grav
1601 phis = 0.0
1602 r0 = PI/9.
1603 p1(1) = PI/4.
1604 p1(2) = PI/6. + (7.5/180.0)*PI
1605 do j=js2,je2
1606 do i=is2,ie2
1607 p2(1) = agrid(i,j,1)
1608 p2(2) = agrid(i,j,2)
1609 r = MIN(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1610 r = SQRT(r)
1611 phis(i,j) = gh0*(1.0-(r/r0))
1612 enddo
1613 enddo
1614 call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1615 delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1616 endif
1617
1618 else if (test_case==11) then
1619 call surfdrv(npx, npy, gridstruct%grid_64, gridstruct%agrid_64, &
1620 gridstruct%area_64, dx, dy, dxa, dya, dxc, dyc, &
1621 gridstruct%sin_sg, phis, &
1622 flagstruct%stretch_fac, gridstruct%nested, &
1623 npx_global, domain, flagstruct%grid_number, bd, flagstruct%regional)
1624 call mpp_update_domains( phis, domain )
1625
1626 if ( hybrid_z ) then
1627 rgrav = 1./ grav
1628 if( npz==32 ) then
1629 call compute_dz_L32( npz, ztop, dz1 )
1630 else
1631 ! call mpp_error(FATAL, 'You must provide a routine for hybrid_z')
1632 if ( is_master() ) write(*,*) 'Using const DZ'
1633 ztop = 45.E3 ! assuming ptop = 100.
1634 dz1(1) = ztop / real(npz)
1635 dz1(npz) = 0.5*dz1(1)
1636 do z=2,npz-1
1637 dz1(z) = dz1(1)
1638 enddo
1639 dz1(1) = 2.*dz1(2)
1640 endif
1641
1642 call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
1643 phis, ze0, delz)
1644 ! call prt_maxmin('ZE0', ze0, is, ie, js, je, 0, npz, 1.E-3)
1645 ! call prt_maxmin('DZ0', delz, is, ie, js, je, 0, npz, 1. )
1646 endif
1647
1648 ! Initialize dry atmosphere
1649 u = 0.
1650 v = 0.
1651 q(:,:,:,:) = 0.
1652 q(:,:,:,1) = 3.e-6
1653
1654 call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1655 delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1656
1657 else if ( (test_case==12) .or. (test_case==13) ) then
1658
1659 #ifdef HIWPP_TRACER
1660 if (is_master()) print*, 'TEST TRACER enabled for this test case'
1661 #ifdef HIWPP
1662 call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
1663 ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
1664 #else
1665 !For consistency with earlier single-grid simulations use gh0 = 1.0e-6 and p1(1) = 195.*pi/180.
1666 q(:,:,:,:) = 0.
1667 gh0 = 1.0e-3
1668 r0 = radius/3. !RADIUS radius/3.
1669 p1(2) = 51.*pi/180.
1670 p1(1) = 205.*pi/180. !231.*pi/180.
1671 do k=1,npz
1672 do j=jsd,jed
1673 do i=isd,ied
1674 p2(1) = agrid(i,j,1)
1675 p2(2) = agrid(i,j,2)
1676 r = great_circle_dist( p1, p2, radius )
1677 if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.) .and. k > 16) then
1678 q(i,j,k,1) = gh0
1679 else
1680 q(i,j,k,1) = 0.
1681 endif
1682 enddo
1683 enddo
1684 enddo
1685 #endif
1686
1687 #else
1688
1689 q(:,:,:,:) = 0.
1690
1691 #ifdef HIWPP
1692
1693 cl = get_tracer_index(MODEL_ATMOS, 'cl')
1694 cl2 = get_tracer_index(MODEL_ATMOS, 'cl2')
1695 if (cl > 0 .and. cl2 > 0) then
1696 call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
1697 q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2))
1698 call mpp_update_domains(q,domain)
1699 endif
1700
1701 #endif
1702 #endif
1703 ! Initialize surface Pressure
1704 ps(:,:) = 1.e5
1705 ! Initialize detla-P
1706 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,ak,ps,bk)
1707 do z=1,npz
1708 do j=js,je
1709 do i=is,ie
1710 delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
1711 enddo
1712 enddo
1713 enddo
1714
1715 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,ptop,peln,pk,delp)
1716 do j=js,je
1717 do i=is, ie
1718 pe(i,1,j) = ptop
1719 peln(i,1,j) = log(ptop)
1720 pk(i,j,1) = ptop**kappa
1721 enddo
1722 ! Top down
1723 do k=2,npz+1
1724 do i=is,ie
1725 pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
1726 pk(i,j,k) = exp( kappa*log(pe(i,k,j)) )
1727 peln(i,k,j) = log(pe(i,k,j))
1728 enddo
1729 enddo
1730 enddo
1731
1732 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,pk,peln)
1733 do k=1,npz
1734 do j=js,je
1735 do i=is,ie
1736 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
1737 enddo
1738 enddo
1739 enddo
1740
1741 ! Setup ETA auxil variable
1742 eta_0 = 0.252
1743 do k=1,npz
1744 eta(k) = 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) )
1745 eta_v(k) = (eta(k) - eta_0)*PI*0.5
1746 enddo
1747
1748 if ( .not. adiabatic ) then
1749 !Set up moisture
1750 sphum = get_tracer_index (MODEL_ATMOS, 'sphum')
1751 pcen(1) = PI/9.
1752 pcen(2) = 2.0*PI/9.
1753 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pe,q,agrid,pcen,delp,peln) &
1754 !$OMP private(ptmp)
1755 do k=1,npz
1756 do j=js,je
1757 do i=is,ie
1758 !r = great_circle_dist(pcen, agrid(i,j,:), radius)
1759 !ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j)) - 100000.
1760 !q(i,j,k,1) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1761 ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - 100000.
1762 q(i,j,k,sphum) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1763 ! SJL:
1764 ! q(i,j,k,sphum) = max(1.e-25, q(i,j,k,sphum))
1765 enddo
1766 enddo
1767 enddo
1768 endif
1769
1770 ! Initialize winds
1771 Ubar = 35.0
1772 r0 = 1.0
1773 pcen(1) = PI/9.
1774 pcen(2) = 2.0*PI/9.
1775 if (test_case == 13) then
1776 #ifdef ALT_PERT
1777 u1 = 0.0
1778 pt0 = 3.0
1779 #else
1780 u1 = 1.0
1781 pt0 = 0.0
1782 #endif
1783 r0 = radius/10.0
1784 endif
1785
1786 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta_v,grid,Ubar,pcen,r0,ee2,v,ee1,es,u,u1,ew) &
1787 !$OMP private(utmp,r,vv1,vv3,p1,p2,vv2,uu1,uu2,uu3,pa)
1788 do z=1,npz
1789 do j=js,je
1790 do i=is,ie+1
1791 utmp = Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i,j+1,2))**2.0
1792 ! Perturbation if Case==13
1793 r = great_circle_dist( pcen, grid(i,j+1,1:2), radius )
1794 if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
1795 vv1 = utmp*(ee2(2,i,j+1)*cos(grid(i,j+1,1)) - ee2(1,i,j+1)*sin(grid(i,j+1,1)))
1796
1797 utmp = Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i,j,2))**2.0
1798 ! Perturbation if Case==13
1799 r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1800 if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
1801 vv3 = utmp*(ee2(2,i,j)*cos(grid(i,j,1)) - ee2(1,i,j)*sin(grid(i,j,1)))
1802 ! Mid-point:
1803 p1(:) = grid(i ,j ,1:2)
1804 p2(:) = grid(i,j+1 ,1:2)
1805 call mid_pt_sphere(p1, p2, pa)
1806 utmp = Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*pa(2))**2.0
1807 ! Perturbation if Case==13
1808 r = great_circle_dist( pcen, pa, radius )
1809 if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
1810 vv2 = utmp*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1811 ! 3-point average:
1812 v(i,j,z) = 0.25*(vv1 + 2.*vv2 + vv3)
1813 enddo
1814 enddo
1815 do j=js,je+1
1816 do i=is,ie
1817 utmp = Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i,j,2))**2.0
1818 ! Perturbation if Case==13
1819 r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1820 if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
1821 uu1 = utmp*(ee1(2,i,j)*cos(grid(i,j,1)) - ee1(1,i,j)*sin(grid(i,j,1)))
1822
1823 utmp = Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*grid(i+1,j,2))**2.0
1824 ! Perturbation if Case==13
1825 r = great_circle_dist( pcen, grid(i+1,j,1:2), radius )
1826 if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
1827 uu3 = utmp*(ee1(2,i+1,j)*cos(grid(i+1,j,1)) - ee1(1,i+1,j)*sin(grid(i+1,j,1)))
1828 ! Mid-point:
1829 p1(:) = grid(i ,j ,1:2)
1830 p2(:) = grid(i+1,j ,1:2)
1831 call mid_pt_sphere(p1, p2, pa)
1832 utmp = Ubar * COS(eta_v(z))**(3.0/2.0) * SIN(2.0*pa(2))**2.0
1833 ! Perturbation if Case==13
1834 r = great_circle_dist( pcen, pa, radius )
1835 if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*EXP(-(r/r0)**2.0)
1836 uu2 = utmp*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1837 ! 3-point average:
1838 u(i,j,z) = 0.25*(uu1 + 2.*uu2 + uu3)
1839 enddo
1840 enddo
1841 enddo ! z-loop
1842
1843 ! Temperature
1844 eta_s = 1.0 ! Surface Level
1845 eta_t = 0.2 ! Tropopause
1846 T_0 = 288.0
1847 delta_T = 480000.0
1848 lapse_rate = 0.005
1849 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta,ak,bk,T_0,lapse_rate,eta_t, &
1850 !$OMP delta_T,ptop,delp,Ubar,eta_v,agrid,grid,pcen,pt,r0) &
1851 !$OMP private(T_mean,press,pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1,r)
1852 do z=1,npz
1853 eta(z) = 0.5*( (ak(z)+ak(z+1))/1.e5 + bk(z)+bk(z+1) )
1854 ! if (is_master()) print*, z, eta
1855 T_mean = T_0 * eta(z)**(RDGAS*lapse_rate/Grav)
1856 if (eta_t > eta(z)) T_mean = T_mean + delta_T*(eta_t - eta(z))**5.0
1857
1858 230 format(i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
1859 press = ptop
1860 do zz=1,z
1861 press = press + delp(is,js,zz)
1862 enddo
1863 if (is_master()) write(*,230) z, eta(z), press/100., T_mean
1864 do j=js,je
1865 do i=is,ie
1866 ! A-grid cell center: i,j
1867 pt1 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1868 ( -2.0*(SIN(agrid(i,j,2))**6.0) *(COS(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1869 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1870 ( (8.0/5.0)*(COS(agrid(i,j,2))**3.0)*(SIN(agrid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1871 #ifndef NO_AVG13
1872 ! 9-point average: should be 2nd order accurate for a rectangular cell
1873 !
1874 ! 9 4 8
1875 !
1876 ! 5 1 3
1877 !
1878 ! 6 2 7
1879 !
1880 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1881 pt2 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1882 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1883 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1884 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1885 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1886 pt3 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1887 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1888 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1889 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1890 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1891 pt4 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1892 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1893 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1894 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1895 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1896 pt5 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1897 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1898 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1899 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1900
1901 pt6 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1902 ( -2.0*(SIN(grid(i,j,2))**6.0) *(COS(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1903 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1904 ( (8.0/5.0)*(COS(grid(i,j,2))**3.0)*(SIN(grid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1905 pt7 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1906 ( -2.0*(SIN(grid(i+1,j,2))**6.0) *(COS(grid(i+1,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1907 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1908 ( (8.0/5.0)*(COS(grid(i+1,j,2))**3.0)*(SIN(grid(i+1,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1909 pt8 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1910 ( -2.0*(SIN(grid(i+1,j+1,2))**6.0) *(COS(grid(i+1,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1911 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1912 ( (8.0/5.0)*(COS(grid(i+1,j+1,2))**3.0)*(SIN(grid(i+1,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1913 pt9 = T_mean + 0.75*(eta(z)*PI*Ubar/RDGAS)*SIN(eta_v(z))*SQRT(COS(eta_v(z))) * ( &
1914 ( -2.0*(SIN(grid(i,j+1,2))**6.0) *(COS(grid(i,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1915 2.0*Ubar*COS(eta_v(z))**(3.0/2.0) + &
1916 ( (8.0/5.0)*(COS(grid(i,j+1,2))**3.0)*(SIN(grid(i,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1917 pt(i,j,z) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1918 #else
1919 pt(i,j,z) = pt1
1920 #endif
1921
1922 #ifdef ALT_PERT
1923 r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
1924 if ( (r/r0)**2 < 40. ) then
1925 pt(i,j,z) = pt(i,j,z) + pt0*exp(-(r/r0)**2)
1926 endif
1927 #endif
1928
1929 enddo
1930 enddo
1931 enddo
1932 if (is_master()) print*,' '
1933 ! Surface Geopotential
1934 phis(:,:)=1.e25
1935 !$OMP parallel do default(none) shared(is2,ie2,js2,je2,Ubar,eta_s,eta_0,agrid,grid,phis) &
1936 !$OMP private(pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1)
1937 do j=js2,je2
1938 do i=is2,ie2
1939 pt1 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1940 ( -2.0*(SIN(agrid(i,j,2))**6.0) *(COS(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1941 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1942 ( (8.0/5.0)*(COS(agrid(i,j,2))**3.0)*(SIN(agrid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1943 #ifndef NO_AVG13
1944 ! 9-point average:
1945 !
1946 ! 9 4 8
1947 !
1948 ! 5 1 3
1949 !
1950 ! 6 2 7
1951 !
1952 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1953 pt2 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1954 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1955 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1956 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1957 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1958 pt3 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1959 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1960 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1961 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1962 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1963 pt4 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1964 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1965 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1966 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1967 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1968 pt5 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1969 ( -2.0*(SIN(p1(2))**6.0) *(COS(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1970 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1971 ( (8.0/5.0)*(COS(p1(2))**3.0)*(SIN(p1(2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1972
1973 pt6 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1974 ( -2.0*(SIN(grid(i,j,2))**6.0) *(COS(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1975 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1976 ( (8.0/5.0)*(COS(grid(i,j,2))**3.0)*(SIN(grid(i,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1977 pt7 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1978 ( -2.0*(SIN(grid(i+1,j,2))**6.0) *(COS(grid(i+1,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1979 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1980 ( (8.0/5.0)*(COS(grid(i+1,j,2))**3.0)*(SIN(grid(i+1,j,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1981 pt8 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1982 ( -2.0*(SIN(grid(i+1,j+1,2))**6.0) *(COS(grid(i+1,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1983 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1984 ( (8.0/5.0)*(COS(grid(i+1,j+1,2))**3.0)*(SIN(grid(i+1,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1985 pt9 = Ubar* (COS( (eta_s-eta_0)*PI/2.0 ))**(3.0/2.0) * ( &
1986 ( -2.0*(SIN(grid(i,j+1,2))**6.0) *(COS(grid(i,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1987 Ubar*COS( (eta_s-eta_0)*PI/2.0 )**(3.0/2.0) + &
1988 ( (8.0/5.0)*(COS(grid(i,j+1,2))**3.0)*(SIN(grid(i,j+1,2))**2.0 + 2.0/3.0) - PI/4.0 )*radius*omega )
1989 phis(i,j) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1990 #else
1991 phis(i,j) = pt1
1992 #endif
1993 enddo
1994 enddo
1995
1996 if ( .not.hydrostatic ) then
1997 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pt,delz,peln,w)
1998 do k=1,npz
1999 do j=js,je
2000 do i=is,ie
2001 w(i,j,k) = 0.
2002 delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
2003 enddo
2004 enddo
2005 enddo
2006 endif
2007 !Assume pt is virtual temperature at this point; then convert to regular temperature
2008 if (.not. adiabatic) then
2009 zvir = rvgas/rdgas - 1.
2010 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pt,zvir,q)
2011 do k=1,npz
2012 do j=js,je
2013 do i=is,ie
2014 pt(i,j,k) = pt(i,j,k)/(1. + zvir*q(i,j,k,sphum))
2015 enddo
2016 enddo
2017 enddo
2018 endif
2019
2020 !Set up tracer #2 to be the initial EPV
2021 ! call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,2))
2022 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
2023
2024 write(stdout(), *) 'PI:', pi
2025 write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
2026
2027 else if ( (test_case==-12) .or. (test_case==-13) ) then
2028
2029 call DCMIP16_BC(delp,pt,u,v,q,w,delz, &
2030 is,ie,js,je,isd,ied,jsd,jed,npz,ncnst,ak,bk,ptop, &
2031 pk,peln,pe,pkz,gz,phis,ps,grid,agrid,hydrostatic, &
2032 nwat, adiabatic, test_case == -13, domain)
2033
2034 write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
2035
2036 else if ( test_case==15 .or. test_case==19 ) then
2037 !------------------------------------
2038 ! Non-hydrostatic 3D density current:
2039 !------------------------------------
2040 ! C100_L64; hybrid_z = .T., make_nh = .F. , make_hybrid_z = .false.
2041 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
2042
2043 if ( test_case == 19 ) then
2044 f0(:,:) = 0.
2045 fC(:,:) = 0.
2046 endif
2047
2048 phis = 0.
2049 u = 0.
2050 v = 0.
2051 w = 0.
2052 t00 = 300.
2053 p00 = 1.E5
2054 pk0 = p00**kappa
2055 ! Set up vertical coordinare with constant del-z spacing:
2056 ztop = 6.4E3
2057 ze1( 1) = ztop
2058 ze1(npz+1) = 0.
2059 do k=npz,2,-1
2060 ze1(k) = ze1(k+1) + ztop/real(npz)
2061 enddo
2062
2063 ! Provide some room for the top layer
2064 ze1(1) = ztop + 1.5*ztop/real(npz)
2065
2066 do j=js,je
2067 do i=is,ie
2068 ps(i,j) = p00
2069 pe(i,npz+1,j) = p00
2070 pk(i,j,npz+1) = pk0
2071 enddo
2072 enddo
2073
2074 do k=npz,1,-1
2075 do j=js,je
2076 do i=is,ie
2077 delz(i,j,k) = ze1(k+1) - ze1(k)
2078 pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
2079 pe(i,k,j) = pk(i,j,k)**(1./kappa)
2080 enddo
2081 enddo
2082 enddo
2083
2084 ptop = pe(is,1,js)
2085 if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
2086
2087 do k=1,npz+1
2088 do j=js,je
2089 do i=is,ie
2090 peln(i,k,j) = log(pe(i,k,j))
2091 ze0(i,j,k) = ze1(k)
2092 enddo
2093 enddo
2094 enddo
2095
2096 do k=1,npz
2097 do j=js,je
2098 do i=is,ie
2099 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2100 delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2101 pt(i,j,k) = t00/pk0 ! potential temp
2102 enddo
2103 enddo
2104 enddo
2105
2106 ! Perturbation: center at 3 km from the ground
2107 pturb = 15.
2108 p1(1) = pi
2109 p1(2) = 0.
2110
2111 do k=1,npz
2112 #ifndef STD_BUBBLE
2113 r0 = 0.5*(ze1(k)+ze1(k+1)) - 3.2E3
2114 #else
2115 r0 = (0.5*(ze1(k)+ze1(k+1)) - 3.0E3) / 2.E3
2116 #endif
2117 do j=js,je
2118 do i=is,ie
2119 ! Impose perturbation in potential temperature: pturb
2120 p2(1) = agrid(i,j,1)
2121 p2(2) = agrid(i,j,2)
2122 #ifndef STD_BUBBLE
2123 r = great_circle_dist( p1, p2, radius )
2124 dist = sqrt( r**2 + r0**2 ) / 3.2E3
2125 #else
2126 r = great_circle_dist( p1, p2, radius ) / 4.E3
2127 dist = sqrt( r**2 + r0**2 )
2128 #endif
2129 if ( dist<=1. ) then
2130 q(i,j,k,1) = pk0 * pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2131 pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2132 else
2133 q(i,j,k,1) = 0.
2134 endif
2135 ! Transform back to temperature:
2136 pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
2137 enddo
2138 enddo
2139 enddo
2140
2141 else if ( test_case==16 ) then
2142
2143 ! Non-rotating:
2144 f0(:,:) = 0.
2145 fC(:,:) = 0.
2146 ! Initialize dry atmosphere
2147 phis = 0.
2148 u = 0.
2149 v = 0.
2150 p00 = 1000.E2
2151 ! Set up vertical coordinare with constant del-z spacing:
2152 ztop = 10.E3
2153 call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2154
2155 do z=1,npz+1
2156 pe1(z) = ak(z) + bk(z)*p00
2157 enddo
2158
2159 ze1(npz+1) = 0.
2160 do z=npz,2,-1
2161 ze1(z) = ze1(z+1) + ztop/real(npz)
2162 enddo
2163 ze1(1) = ztop
2164
2165 if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2166
2167 do j=jsd,jed
2168 do i=isd,ied
2169 ps(i,j) = pe1(npz+1)
2170 enddo
2171 enddo
2172
2173 do z=1,npz+1
2174 do j=js,je
2175 do i=is,ie
2176 pe(i,z,j) = pe1(z)
2177 peln(i,z,j) = log(pe1(z))
2178 pk(i,j,z) = exp(kappa*peln(i,z,j))
2179 enddo
2180 enddo
2181 enddo
2182
2183 ! Horizontal shape function
2184 p1(1) = pi
2185 p1(2) = 0.
2186 r0 = radius / 3.
2187 do j=js,je
2188 do i=is,ie
2189 r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2190 if ( r<r0 ) then
2191 vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2192 else
2193 vort(i,j) = 0
2194 endif
2195 enddo
2196 enddo
2197
2198 q = 0.
2199 pk0 = p00**kappa
2200 pturb = 10./pk0
2201 do z=1,npz
2202 zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2203 do j=js,je
2204 do i=is,ie
2205 pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2206 delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2207 ! Impose perturbation in potential temperature: pturb
2208 pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2209 q(i,j,z,1) = q(i,j,z,1) + vort(i,j)*zmid
2210 enddo
2211 enddo
2212 enddo
2213
2214 elseif ( test_case==17 ) then
2215 ! Initialize dry atmosphere
2216 phis = 0.
2217 u = 0.
2218 v = 0.
2219 p00 = 1000.E2
2220 ! Set up vertical coordinare with constant del-z spacing:
2221 ztop = 10.E3
2222 call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2223
2224 do z=1,npz+1
2225 pe1(z) = ak(z) + bk(z)*p00
2226 enddo
2227
2228 ze1(npz+1) = 0.
2229 do z=npz,2,-1
2230 ze1(z) = ze1(z+1) + ztop/real(npz)
2231 enddo
2232 ze1(1) = ztop
2233
2234 if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2235
2236 do j=jsd,jed
2237 do i=isd,ied
2238 ps(i,j) = pe1(npz+1)
2239 enddo
2240 enddo
2241
2242 do z=1,npz+1
2243 do j=js,je
2244 do i=is,ie
2245 pe(i,z,j) = pe1(z)
2246 peln(i,z,j) = log(pe1(z))
2247 pk(i,j,z) = exp(kappa*peln(i,z,j))
2248 enddo
2249 enddo
2250 enddo
2251
2252 ! Horizontal shape function
2253 p1(1) = pi
2254 p1(2) = pi/4.
2255 r0 = radius / 3.
2256 do j=js,je
2257 do i=is,ie
2258 r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2259 if ( r<r0 ) then
2260 vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2261 else
2262 vort(i,j) = 0
2263 endif
2264 enddo
2265 enddo
2266
2267 pk0 = p00**kappa
2268 pturb = 10./pk0
2269 do z=1,npz
2270 zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2271 do j=js,je
2272 do i=is,ie
2273 pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2274 delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2275 ! Impose perturbation in potential temperature: pturb
2276 pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2277 enddo
2278 enddo
2279 enddo
2280
2281 elseif ( test_case==18 ) then
2282 ubar = 20.
2283 pt0 = 288.
2284 n2 = grav**2 / (cp_air*pt0)
2285
2286 pcen(1) = PI/2.
2287 pcen(2) = PI/6.
2288
2289 ! Initialize surface Pressure
2290 do j=js2,je2
2291 do i=is2,ie2
2292 r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
2293 phis(i,j) = grav*2.E3*exp( -(r/1500.E3)**2 )
2294 ps(i,j) = 930.E2 * exp( -radius*n2*ubar/(2.*grav*grav*kappa)*(ubar/radius+2.*omega)* &
2295 (sin(agrid(i,j,2))**2-1.) - n2/(grav*grav*kappa)*phis(i,j))
2296 enddo
2297 enddo
2298
2299 do z=1,npz
2300 do j=js,je
2301 do i=is,ie
2302 pt(i,j,z) = pt0
2303 delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
2304 enddo
2305 enddo
2306 ! v-wind:
2307 do j=js,je
2308 do i=is,ie+1
2309 p1(:) = grid(i ,j ,1:2)
2310 p2(:) = grid(i,j+1 ,1:2)
2311 call mid_pt_sphere(p1, p2, p3)
2312 call get_unit_vect2(p1, p2, e2)
2313 call get_latlon_vector(p3, ex, ey)
2314 utmp = ubar * cos(p3(2))
2315 vtmp = 0.
2316 v(i,j,z) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2317 enddo
2318 enddo
2319
2320 ! u-wind
2321 do j=js,je+1
2322 do i=is,ie
2323 p1(:) = grid(i, j,1:2)
2324 p2(:) = grid(i+1,j,1:2)
2325 call mid_pt_sphere(p1, p2, p3)
2326 call get_unit_vect2(p1, p2, e1)
2327 call get_latlon_vector(p3, ex, ey)
2328 utmp = ubar * cos(p3(2))
2329 vtmp = 0.
2330 u(i,j,z) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2331 enddo
2332 enddo
2333 enddo
2334
2335 else if ( test_case==20 .or. test_case==21 ) then
2336 !------------------------------------
2337 ! Non-hydrostatic 3D lee vortices
2338 !------------------------------------
2339 f0(:,:) = 0.
2340 fC(:,:) = 0.
2341
2342 if ( test_case == 20 ) then
2343 Ubar = 4. ! u = Ubar * cos(lat)
2344 ftop = 2.0E3 * grav
2345 else
2346 Ubar = 8. ! u = Ubar * cos(lat)
2347 ftop = 4.0E3 * grav
2348 endif
2349
2350 w = 0.
2351
2352 do j=js,je
2353 do i=is,ie+1
2354 p1(:) = grid(i ,j ,1:2)
2355 p2(:) = grid(i,j+1 ,1:2)
2356 call mid_pt_sphere(p1, p2, p3)
2357 call get_unit_vect2(p1, p2, e2)
2358 call get_latlon_vector(p3, ex, ey)
2359 utmp = ubar * cos(p3(2))
2360 vtmp = 0.
2361 v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2362 enddo
2363 enddo
2364 do j=js,je+1
2365 do i=is,ie
2366 p1(:) = grid(i, j,1:2)
2367 p2(:) = grid(i+1,j,1:2)
2368 call mid_pt_sphere(p1, p2, p3)
2369 call get_unit_vect2(p1, p2, e1)
2370 call get_latlon_vector(p3, ex, ey)
2371 utmp = ubar * cos(p3(2))
2372 vtmp = 0.
2373 u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2374 enddo
2375 enddo
2376
2377 ! copy vertically; no wind shear
2378 do k=2,npz
2379 do j=js,je+1
2380 do i=is,ie
2381 u(i,j,k) = u(i,j,1)
2382 enddo
2383 enddo
2384 do j=js,je
2385 do i=is,ie+1
2386 v(i,j,k) = v(i,j,1)
2387 enddo
2388 enddo
2389 enddo
2390
2391 ! Center of the mountain:
2392 p1(1) = (0.5-0.125) * pi
2393 p1(2) = 0.
2394 call latlon2xyz(p1, e1)
2395 uu1 = 5.0E3
2396 uu2 = 10.0E3
2397 do j=js2,je2
2398 do i=is2,ie2
2399 p2(:) = agrid(i,j,1:2)
2400 r = great_circle_dist( p1, p2, radius )
2401 if ( r < pi*radius ) then
2402 p4(:) = p2(:) - p1(:)
2403 if ( abs(p4(1)) > 1.E-12 ) then
2404 zeta = asin ( p4(2) / sqrt(p4(1)**2 + p4(2)**2) )
2405 else
2406 zeta = pi/2.
2407 endif
2408 if ( p4(1) <= 0. ) zeta = pi - zeta
2409 zeta = zeta + pi/6.
2410 v1 = r/uu1 * cos( zeta )
2411 v2 = r/uu2 * sin( zeta )
2412 phis(i,j) = ftop / ( 1. + v1**2 + v2**2 )
2413 else
2414 phis(i,j) = 0.
2415 endif
2416 enddo
2417 enddo
2418
2419 if ( hybrid_z ) then
2420 rgrav = 1./ grav
2421 if( npz==32 ) then
2422 call compute_dz_L32( npz, ztop, dz1 )
2423 elseif( npz.eq.31 .or. npz.eq.41 .or. npz.eq.51 ) then
2424 ztop = 16.E3
2425 call hybrid_z_dz(npz, dz1, ztop, 1.0)
2426 else
2427 if ( is_master() ) write(*,*) 'Using const DZ'
2428 ztop = 15.E3
2429 dz1(1) = ztop / real(npz)
2430 do k=2,npz
2431 dz1(k) = dz1(1)
2432 enddo
2433 ! Make top layer thicker
2434 dz1(1) = max( 1.0E3, 3.*dz1(2) ) ! min 1 km
2435 endif
2436
2437 ! Re-compute ztop
2438 ze1(npz+1) = 0.
2439 do k=npz,1,-1
2440 ze1(k) = ze1(k+1) + dz1(k)
2441 enddo
2442 ztop = ze1(1)
2443
2444 call set_hybrid_z( is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
2445 phis, ze0, delz )
2446 else
2447 call mpp_error(FATAL, 'This test case is only currently setup for hybrid_z')
2448 endif
2449
2450 do k=1,npz
2451 do j=js,je
2452 do i=is,ie
2453 delz(i,j,k) = ze0(i,j,k+1) - ze0(i,j,k)
2454 enddo
2455 enddo
2456 enddo
2457
2458 p00 = 1.E5 ! mean SLP
2459 pk0 = p00**kappa
2460 t00 = 300.
2461 pt0 = t00/pk0
2462 n2 = 1.E-4
2463 s0 = grav*grav / (cp_air*n2)
2464
2465 ! For constant N2, Given z --> p
2466 do k=1,npz+1
2467 pe1(k) = p00*( (1.-s0/t00) + s0/t00*exp(-n2*ze1(k)/grav) )**(1./kappa)
2468 enddo
2469
2470 ptop = pe1(1)
2471 if ( is_master() ) write(*,*) 'Lee vortex testcase: model top (mb)=', ptop/100.
2472
2473 ! Set up fake "sigma" coordinate
2474 ak(1) = pe1(1)
2475 bk(1) = 0.
2476 do k=2,npz
2477 bk(k) = (pe1(k) - pe1(1)) / (pe1(npz+1)-pe1(1)) ! bk == sigma
2478 ak(k) = pe1(1)*(1.-bk(k))
2479 enddo
2480 ak(npz+1) = 0.
2481 bk(npz+1) = 1.
2482
2483 ! Assuming constant N
2484 do k=2,npz+1
2485 do j=js,je
2486 do i=is,ie
2487 pk(i,j,k) = pk0 - (1.-exp(-n2/grav*ze0(i,j,k))) * (grav*grav)/(n2*cp_air*pt0)
2488 pe(i,k,j) = pk(i,j,k) ** (1./kappa)
2489 peln(i,k,j) = log(pe(i,k,j))
2490 enddo
2491 enddo
2492 enddo
2493
2494 do j=js,je
2495 do i=is,ie
2496 pe(i,1,j) = ptop
2497 peln(i,1,j) = log(pe(i,1,j))
2498 pk(i,j,1) = pe(i,1,j) ** kappa
2499 ps(i,j) = pe(i,npz+1,j)
2500 enddo
2501 enddo
2502
2503 do k=1,npz
2504 do j=js,je
2505 do i=is,ie
2506 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2507 delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2508 pt(i,j,k) = pkz(i,j,k)*grav*delz(i,j,k) / ( cp_air*(pk(i,j,k)-pk(i,j,k+1)) )
2509 enddo
2510 enddo
2511 enddo
2512
2513 else if (test_case == 51) then
2514
2515 alpha = 0.
2516 t00 = 300.
2517
2518
2519 if (.not.hydrostatic) w(:,:,:)= 0.0
2520
2521
2522 select case (tracer_test)
2523 case (1) !DCMIP 11
2524
2525 !Need to set up pressure arrays
2526 !!$ p00 = 1.e5
2527 !!$ ps = p00
2528 !!$ phis = 0.
2529
2530 !NOTE: since we have an isothermal atmosphere and specify constant height-thickness layers we will disregard ak and bk and specify the initial pressures in a different way
2531
2532 dz = 12000./real(npz)
2533
2534 allocate(zz0(npz+1))
2535 allocate(pz0(npz+1))
2536
2537 zz0(1) = 12000.
2538 do k=2,npz
2539 zz0(k) = zz0(k-1) - dz
2540 enddo
2541 zz0(npz+1) = 0.
2542
2543 if (is_master()) print*, 'TRACER ADVECTION TEST CASE'
2544 if (is_master()) print*, 'INITIAL LEVELS'
2545 !This gets interface pressure from input z-levels
2546 do k=1,npz+1
2547 !call test1_advection_deformation(agrid(is,js,1), agrid(is,js,2), pz0(k), zz0(k), 1, &
2548 ! ua(is,js,1), va(is,js,1), dum1, pt(is,js,1), phis(is,js), &
2549 ! ps(is,js), dum2, dum3, q(is,js,1,1), q(is,js,1,2), q(is,js,1,3), q(is,js,1,4))
2550 if (is_master()) write(*,*) k, pz0(k), zz0(k)
2551 enddo
2552
2553 !Pressure
2554 do j=js,je
2555 do k=1,npz+1
2556 do i=is,ie
2557 pe(i,k,j) = pz0(k)
2558 enddo
2559 enddo
2560 enddo
2561
2562 do k=1,npz
2563 ptmp = 0.5*(pz0(k) + pz0(k+1))
2564 do j=js,je
2565 do i=is,ie
2566 !This gets level-mean values from input pressures
2567 !call test1_advection_deformation(agrid(i,j,1),agrid(i,j,2),ptmp,dum,0, &
2568 ! ua(i,j,k), va(i,j,k), dum4, pt(i,j,k), phis(i,j), &
2569 ! ps(i,j), dum2, dum3, q(i,j,k,1), q(i,j,k,2), q(i,j,k,3), q(i,j,k,4))
2570 delp(i,j,k) = pz0(k+1)-pz0(k)
2571 enddo
2572 enddo
2573 enddo
2574
2575 ptop = 100000.*exp(-12000.*grav/t00/rdgas)
2576
2577
2578 psi(:,:) = 1.e25
2579 psi_b(:,:) = 1.e25
2580 do j=jsd,jed
2581 do i=isd,ied
2582 psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
2583 cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
2584 enddo
2585 enddo
2586 call mpp_update_domains( psi, domain )
2587 do j=jsd,jed+1
2588 do i=isd,ied+1
2589 psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
2590 cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
2591 enddo
2592 enddo
2593
2594 k = 1
2595 do j=js,je+1
2596 do i=is,ie
2597 dist = dx(i,j)
2598 vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
2599 if (dist==0) vc(i,j,k) = 0.
2600 enddo
2601 enddo
2602 do j=js,je
2603 do i=is,ie+1
2604 dist = dy(i,j)
2605 uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
2606 if (dist==0) uc(i,j,k) = 0.
2607 enddo
2608 enddo
2609
2610 do j=js,je
2611 do i=is,ie+1
2612 dist = dxc(i,j)
2613 v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
2614 if (dist==0) v(i,j,k) = 0.
2615 enddo
2616 enddo
2617 do j=js,je+1
2618 do i=is,ie
2619 dist = dyc(i,j)
2620 u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
2621 if (dist==0) u(i,j,k) = 0.
2622 enddo
2623 enddo
2624
2625 do j=js,je
2626 do i=is,ie
2627 psi1 = 0.5*(psi(i,j)+psi(i,j-1))
2628 psi2 = 0.5*(psi(i,j)+psi(i,j+1))
2629 dist = dya(i,j)
2630 ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
2631 if (dist==0) ua(i,j,k) = 0.
2632 psi1 = 0.5*(psi(i,j)+psi(i-1,j))
2633 psi2 = 0.5*(psi(i,j)+psi(i+1,j))
2634 dist = dxa(i,j)
2635 va(i,j,k) = (psi2 - psi1) / (dist)
2636 if (dist==0) va(i,j,k) = 0.
2637 enddo
2638 enddo
2639
2640 do k=2,npz
2641 u(:,:,k) = u(:,:,1)
2642 v(:,:,k) = v(:,:,1)
2643 uc(:,:,k) = uc(:,:,1)
2644 vc(:,:,k) = vc(:,:,1)
2645 ua(:,:,k) = ua(:,:,1)
2646 va(:,:,k) = va(:,:,1)
2647 enddo
2648
2649 call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
2650 call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.)
2651 call mp_update_dwinds(u, v, npx, npy, npz, domain)
2652
2653 case (2) !DCMIP 12
2654
2655 case (3) !DCMIP 13
2656
2657 case default
2658 call mpp_error(FATAL, 'Value of tracer_test not implemented ')
2659 end select
2660
2661 else if (test_case == 52) then
2662
2663 !Orography and steady-state test: DCMIP 20
2664
2665
2666 f0 = 0.
2667 fC = 0.
2668
2669 u = 0.
2670 v = 0.
2671
2672 p00 = 1.e5
2673
2674 wind_field = tracer_test
2675
2676 if (.not.hydrostatic) w(:,:,:)= 0.0
2677
2678 !Set up ak and bk
2679
2680 dz = 12000./real(npz)
2681 T00 = 300.
2682 p00 = 1.e5
2683 H = rdgas*T00/grav
2684 gamma = 0.0065
2685 exponent = Rdgas*gamma/grav
2686 px = ((t00-9000.*gamma)/t00)**(1./exponent) !p00 not multiplied in
2687
2688
2689 do k=1,npz+1
2690 height = 12000. - dz*real(k-1)
2691 if (height >= 9000. ) then
2692 ak(k) = p00*((t00-height*gamma)/t00)**(1./exponent)
2693 bk(k) = 0.
2694 else
2695 ak(k) = (((t00-height*gamma)/t00)**(1./exponent)-1.)/(px - 1.)*px*p00
2696 bk(k) = (((t00-height*gamma)/t00)**(1./exponent)-px)/(1.-px)
2697 endif
2698 if (is_master()) write(*,*) k, ak(k), bk(k), height, ak(k)+bk(k)*p00
2699 enddo
2700
2701 ptop = ak(1)
2702
2703 !Need to set up uniformly-spaced levels
2704 p1(1) = 3.*pi/2. ; p1(2) = 0.
2705 r0 = 0.75*pi
2706 zetam = pi/16.
2707
2708 !Topography
2709 do j=js,je
2710 do i=is,ie
2711 p2(:) = agrid(i,j,1:2)
2712 r = great_circle_dist( p1, p2, one )
2713 if (r < r0) then
2714 phis(i,j) = grav*0.5*2000.*(1. + cos(pi*r/r0))*cos(pi*r/zetam)**2.
2715 pe(i,npz+1,j) = p00*(1.-gamma/T00*phis(i,j)/grav)**(1./exponent)
2716 else
2717 phis(i,j) = 0.
2718 pe(i,npz+1,j) = p00
2719 endif
2720 ps(i,j) = pe(i,npz+1,j)
2721 enddo
2722 enddo
2723
2724 do j=js,je
2725 do k=1,npz
2726 do i=is,ie
2727 pe(i,k,j) = ak(k) + bk(k)*ps(i,j)
2728 gz(i,j,k) = t00/gamma*(1. - (pe(i,k,j)/p00)**exponent)
2729 enddo
2730 enddo
2731 enddo
2732
2733 do k=1,npz
2734 do j=js,je
2735 do i=is,ie
2736
2737 !call test2_steady_state_mountain(agrid(i,j,1),agrid(i,j,2),dum, dum2, 0, .true., &
2738 ! 0.5*(ak(k)+ak(k+1)), 0.5*(bk(k)+bk(k+1)), dum3, dum4, dum5, &
2739 ! pt(i,j,k), phis(i,j), ps(i,j), dum6, q(i,j,k,1))
2740 delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
2741 !Analytic point-value
2742 !!$ ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
2743 !!$ pt(i,j,k) = t00*(ptmp/p00)**exponent
2744 !ANalytic layer-mean
2745 pt(i,j,k) = -grav*t00*p00/(rdgas*gamma + grav)/delp(i,j,k) * &
2746 ( (pe(i,k,j)/p00)**(exponent+1.) - (pe(i,k+1,j)/p00)**(exponent+1.) )
2747
2748
2749 enddo
2750 enddo
2751 enddo
2752
2753 else if ( abs(test_case)==30 .or. abs(test_case)==31 ) then
2754 !------------------------------------
2755 ! Super-Cell; with or with rotation
2756 !------------------------------------
2757 if ( abs(test_case)==30) then
2758 f0(:,:) = 0.
2759 fC(:,:) = 0.
2760 endif
2761
2762 zvir = rvgas/rdgas - 1.
2763 p00 = 1000.E2
2764 ps(:,:) = p00
2765 phis(:,:) = 0.
2766 do j=js,je
2767 do i=is,ie
2768 pk(i,j,1) = ptop**kappa
2769 pe(i,1,j) = ptop
2770 peln(i,1,j) = log(ptop)
2771 enddo
2772 enddo
2773
2774 do k=1,npz
2775 do j=js,je
2776 do i=is,ie
2777 delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
2778 pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
2779 peln(i,k+1,j) = log(pe(i,k+1,j))
2780 pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
2781 enddo
2782 enddo
2783 enddo
2784
2785 i = is
2786 j = js
2787 do k=1,npz
2788 pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2789 enddo
2790
2791
2792 w(:,:,:) = 0.
2793 q(:,:,:,:) = 0.
2794
2795 pp0(1) = 262.0/180.*pi ! OKC
2796 pp0(2) = 35.0/180.*pi
2797
2798 do k=1,npz
2799 do j=js,je
2800 do i=is,ie
2801 pt(i,j,k) = ts1(k)
2802 q(i,j,k,1) = qs1(k)
2803 delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
2804 enddo
2805 enddo
2806 enddo
2807
2808 ze1(npz+1) = 0.
2809 do k=npz,1,-1
2810 ze1(k) = ze1(k+1) - delz(is,js,k)
2811 enddo
2812
2813 us0 = 30.
2814 if (is_master()) then
2815 if (test_case > 0) then
2816 write(6,*) 'Toy supercell winds, piecewise approximation'
2817 else
2818 write(6,*) 'Toy supercell winds, tanh approximation'
2819 endif
2820 endif
2821 do k=1,npz
2822
2823 zm = 0.5*(ze1(k)+ze1(k+1))
2824 ! Quarter-circle hodograph (Harris approximation)
2825
2826 if (test_case > 0) then
2827 ! SRH = 40
2828 if ( zm .le. 2.e3 ) then
2829 utmp = 8.*(1.-cos(pi*zm/4.e3))
2830 vtmp = 8.*sin(pi*zm/4.e3)
2831 elseif (zm .le. 6.e3 ) then
2832 utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
2833 vtmp = 8.
2834 else
2835 utmp = us0
2836 vtmp = 8.
2837 endif
2838 ubar = utmp - 8.
2839 vbar = vtmp - 4.
2840 else
2841 ! SRH = 39
2842 utmp = 15.0*(1.+tanh(zm/2000. - 1.5))
2843 vtmp = 8.5*tanh(zm/1000.)
2844 ubar = utmp - 8.5
2845 vbar = vtmp - 4.25
2846 !!$ ! SRH = 45
2847 !!$ utmp = 16.0*(1.+tanh(zm/2000. - 1.4))
2848 !!$ vtmp = 8.5*tanh(zm/1000.)
2849 !!$ ubar = utmp - 10.
2850 !!$ vbar = vtmp - 4.25
2851 !!$ ! SRH = 27 (really)
2852 !!$ utmp = 0.5*us0*(1.+tanh((zm-3500.)/2000.))
2853 !!$ vtmp = 8.*tanh(zm/1000.)
2854 !!$ ubar = utmp - 10.
2855 !!$ vbar = vtmp - 4.
2856 endif
2857
2858 if( is_master() ) then
2859 write(6,*) k, utmp, vtmp
2860 endif
2861
2862 do j=js,je
2863 do i=is,ie+1
2864 p1(:) = grid(i ,j ,1:2)
2865 p2(:) = grid(i,j+1 ,1:2)
2866 call mid_pt_sphere(p1, p2, p3)
2867 call get_unit_vect2(p1, p2, e2)
2868 call get_latlon_vector(p3, ex, ey)
2869 ! Scaling factor is a Gaussian decay from center
2870 v(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2871 (ubar*inner_prod(e2,ex) + vbar*inner_prod(e2,ey))
2872 enddo
2873 enddo
2874 do j=js,je+1
2875 do i=is,ie
2876 p1(:) = grid(i, j,1:2)
2877 p2(:) = grid(i+1,j,1:2)
2878 call mid_pt_sphere(p1, p2, p3)
2879 call get_unit_vect2(p1, p2, e1)
2880 call get_latlon_vector(p3, ex, ey)
2881 ! Scaling factor is a Gaussian decay from center
2882 u(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2883 (ubar*inner_prod(e1,ex) + vbar*inner_prod(e1,ey))
2884 enddo
2885 enddo
2886 enddo
2887
2888 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
2889 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
2890 .true., hydrostatic, nwat, domain)
2891
2892 ! *** Add Initial perturbation ***
2893 pturb = 2.
2894 r0 = 10.e3 ! radius
2895 zc = 1.4e3 ! center of bubble from surface
2896 do k=1, npz
2897 zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
2898 ptmp = ( (zm-zc)/zc ) **2
2899 if ( ptmp < 1. ) then
2900 do j=js,je
2901 do i=is,ie
2902 dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
2903 if ( dist < 1. ) then
2904 pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
2905 endif
2906 enddo
2907 enddo
2908 endif
2909 enddo
2910
2911 elseif (test_case == 32) then
2912
2913 call mpp_error(FATAL, ' test_case 32 not yet implemented')
2914
2915 else if ( test_case==33 .or. test_case==34 .or. test_case==35 ) then
2916 !------------------------------------
2917 ! HIWPP M0ountain waves tests
2918 !------------------------------------
2919 f0(:,:) = 0.
2920 fC(:,:) = 0.
2921
2922 phis(:,:) = 1.E30
2923 ps(:,:) = 1.E30
2924
2925 zvir = 0.
2926 p00 = 1000.E2
2927 t00 = 300.
2928 us0 = 20.
2929 ! Vertical shear parameter for M3 case:
2930 if ( test_case == 35 ) then
2931 cs_m3 = 2.5e-4
2932 else
2933 cs_m3 = 0.
2934 endif
2935
2936 ! Mountain height:
2937 h0 = 250.
2938 ! Mountain center
2939 p0(1) = 60./180. * pi
2940 p0(2) = 0.
2941 ! 9-point average:
2942 ! 9 4 8
2943 !
2944 ! 5 1 3
2945 !
2946 ! 6 2 7
2947 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
2948 if ( test_case==35 ) then
2949 dum = -cs_m3/grav
2950 do j=js,je
2951 do i=is,ie
2952 ! temperature is function of latitude (due to vertical shear)
2953 #ifdef USE_CELL_AVG
2954 p2(2) = agrid(i,j,2)
2955 pt1 = exp( dum*(us0*sin(p2(2)))**2 )
2956 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2957 pt2 = exp( dum*(us0*sin(p2(2)))**2 )
2958 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2959 pt3 = exp( dum*(us0*sin(p2(2)))**2 )
2960 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
2961 pt4 = exp( dum*(us0*sin(p2(2)))**2 )
2962 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
2963 pt5 = exp( dum*(us0*sin(p2(2)))**2 )
2964 p2(2) = grid(i,j,2)
2965 pt6 = exp( dum*(us0*sin(p2(2)))**2 )
2966 p2(2) = grid(i+1,j,2)
2967 pt7 = exp( dum*(us0*sin(p2(2)))**2 )
2968 p2(2) = grid(i+1,j+1,2)
2969 pt8 = exp( dum*(us0*sin(p2(2)))**2 )
2970 p2(2) = grid(i,j+1,2)
2971 pt9 = exp( dum*(us0*sin(p2(2)))**2 )
2972 ptmp = t00*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
2973 #else
2974 ptmp = t00*exp( dum*(us0*sin(agrid(i,j,2)))**2 )
2975 #endif
2976 do k=1,npz
2977 pt(i,j,k) = ptmp
2978 enddo
2979 enddo
2980 enddo
2981 else
2982 pt(:,:,:) = t00
2983 endif
2984
2985 if( test_case==33 ) then
2986 ! NCAR Ridge-mountain Mods:
2987 do j=js,je
2988 do i=is,ie
2989 #ifdef USE_CELL_AVG
2990 p2(1:2) = agrid(i,j,1:2)
2991 r = radius*(p2(1)-p0(1))
2992 pt1 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2993 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2994 r = radius*(p2(1)-p0(1))
2995 pt2 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2996 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2997 r = radius*(p2(1)-p0(1))
2998 pt3 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2999 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
3000 r = radius*(p2(1)-p0(1))
3001 pt4 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3002 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
3003 r = radius*(p2(1)-p0(1))
3004 pt5 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3005 p2(1:2) = grid(i,j,1:2)
3006 r = radius*(p2(1)-p0(1))
3007 pt6 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3008 p2(1:2) = grid(i+1,j,1:2)
3009 r = radius*(p2(1)-p0(1))
3010 pt7 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3011 p2(1:2) = grid(i+1,j+1,1:2)
3012 r = radius*(p2(1)-p0(1))
3013 pt8 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3014 p2(1:2) = grid(i,j+1,1:2)
3015 r = radius*(p2(1)-p0(1))
3016 pt9 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3017 phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
3018 #else
3019 p2(1:2) = agrid(i,j,1:2)
3020 r = radius*(p2(1)-p0(1))
3021 phis(i,j) = grav*h0*cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3022 #endif
3023 enddo
3024 enddo
3025 else
3026 ! Circular mountain:
3027 do j=js,je
3028 do i=is,ie
3029 ! 9-point average:
3030 ! 9 4 8
3031 !
3032 ! 5 1 3
3033 !
3034 ! 6 2 7
3035 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
3036 #ifdef USE_CELL_AVG
3037 r = great_circle_dist( p0, agrid(i,j,1:2), radius )
3038 pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3039 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
3040 r = great_circle_dist( p0, p2, radius )
3041 pt2 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3042 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
3043 r = great_circle_dist( p0, p2, radius )
3044 pt3 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3045 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
3046 r = great_circle_dist( p0, p2, radius )
3047 pt4 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3048 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
3049 r = great_circle_dist( p0, p2, radius )
3050 pt5 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3051 r = great_circle_dist( p0, grid(i,j,1:2), radius )
3052 pt6 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3053 r = great_circle_dist( p0, grid(i+1,j,1:2), radius )
3054 pt7 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3055 r = great_circle_dist( p0, grid(i+1,j+1,1:2), radius )
3056 pt8 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3057 r = great_circle_dist( p0, grid(i,j+1,1:2), radius )
3058 pt9 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3059 phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
3060 #else
3061 r = great_circle_dist( p0, agrid(i,j,1:2), radius )
3062 pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3063 phis(i,j) = grav*h0*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3064 #endif
3065 enddo
3066 enddo
3067 endif
3068
3069 do j=js,je
3070 do i=is,ie
3071 ! DCMIP Eq(33)
3072 ps(i,j) = p00*exp( -0.5*(us0*sin(agrid(i,j,2)))**2/(rdgas*t00)-phis(i,j)/(rdgas*pt(i,j,1)) )
3073 pe(i,1,j) = ptop
3074 peln(i,1,j) = log(ptop)
3075 pk(i,j,1) = ptop**kappa
3076 enddo
3077 enddo
3078
3079 do k=2,npz+1
3080 do j=js,je
3081 do i=is,ie
3082 pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
3083 peln(i,k,j) = log(pe(i,k,j))
3084 pk(i,j,k) = exp( kappa*peln(i,k,j) )
3085 enddo
3086 enddo
3087 enddo
3088
3089 do k=1,npz
3090 do j=js,je
3091 do i=is,ie
3092 delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3093 delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
3094 enddo
3095 enddo
3096 enddo
3097
3098 ! Comnpute mid-level height, using w for temp storage
3099 do j=js,je
3100 do i=is,ie
3101 ze1(npz+1) = phis(i,j)/grav
3102 do k=npz,1,-1
3103 ze1(k) = ze1(k+1) - delz(i,j,k)
3104 enddo
3105 do k=1,npz
3106 w(i,j,k) = 0.5*(ze1(k)+ze1(k+1))
3107 enddo
3108 enddo
3109 enddo
3110 call mpp_update_domains( w, domain )
3111
3112 do k=1,npz
3113 do j=js,je
3114 do i=is,ie+1
3115 p1(:) = grid(i ,j, 1:2)
3116 p2(:) = grid(i,j+1, 1:2)
3117 call mid_pt_sphere(p1, p2, p3)
3118 call get_unit_vect2(p1, p2, e2)
3119 call get_latlon_vector(p3, ex, ey)
3120 ! Joe Klemp's mod:
3121 utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i-1,j,k)+w(i,j,k)) )
3122 v(i,j,k) = utmp*inner_prod(e2,ex)
3123 enddo
3124 enddo
3125 do j=js,je+1
3126 do i=is,ie
3127 p1(:) = grid(i, j, 1:2)
3128 p2(:) = grid(i+1,j, 1:2)
3129 call mid_pt_sphere(p1, p2, p3)
3130 call get_unit_vect2(p1, p2, e1)
3131 call get_latlon_vector(p3, ex, ey)
3132 utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i,j-1,k)+w(i,j,k)) )
3133 u(i,j,k) = utmp*inner_prod(e1,ex)
3134 enddo
3135 enddo
3136 enddo
3137
3138 w(:,:,:) = 0. ! reset w
3139 q(:,:,:,:) = 0.
3140
3141 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3142 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
3143 .true., hydrostatic, nwat, domain)
3144
3145 else if ( test_case==36 .or. test_case==37 ) then
3146 !------------------------------------
3147 ! HIWPP Super-Cell
3148 !------------------------------------
3149 ! HIWPP SUPER_K;
3150 f0(:,:) = 0.
3151 fC(:,:) = 0.
3152 q(:,:,:,:) = 0.
3153 w(:,:,:) = 0.
3154
3155 zvir = rvgas/rdgas - 1.
3156 p00 = 1000.E2
3157 pk0 = p00**kappa
3158 ps(:,:) = p00
3159 phis(:,:) = 0.
3160 !
3161 ! Set up vertical layer spacing:
3162 ztop = 20.e3
3163 ze1(1) = ztop
3164 ze1(npz+1) = 0.
3165 #ifndef USE_VAR_DZ
3166 ! Truly uniform setup:
3167 do k=npz,2,-1
3168 ze1(k) = ze1(k+1) + ztop/real(npz)
3169 enddo
3170 #else
3171 ! Lowest layer half of the size
3172 ! ze1(npz) = ztop / real(2*npz-1) ! lowest layer thickness
3173 ! zm = (ztop-ze1(npz)) / real(npz-1)
3174 ! do k=npz,2,-1
3175 ! ze1(k) = ze1(k+1) + zm
3176 ! enddo
3177 call var_dz(npz, ztop, ze1)
3178 #endif
3179 do k=1,npz
3180 zs1(k) = 0.5*(ze1(k)+ze1(k+1))
3181 enddo
3182 !-----
3183 ! Get sounding at "equator": initial storm center
3184 call SuperK_Sounding(npz, pe1, p00, ze1, ts1, qs1)
3185 ! ts1 is FV's definition of potential temperature at EQ
3186
3187 do k=1,npz
3188 ts1(k) = cp_air*ts1(k)*(1.+zvir*qs1(k)) ! cp*thelta_v
3189 enddo
3190 ! Initialize the fields on z-coordinate; adjust top layer mass
3191 ! Iterate then interpolate to get balanced pt & pk on the sphere
3192 ! Adjusting ptop
3193 call SuperK_u(npz, zs1, uz1, dudz)
3194 call balanced_K(npz, is, ie, js, je, ng, pe1(npz+1), ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
3195 delz, zvir, ptop, ak, bk, agrid)
3196 do j=js,je
3197 do i=is,ie
3198 ps(i,j) = pe(i,npz+1,j)
3199 enddo
3200 enddo
3201
3202 do k=1,npz+1
3203 do j=js,je
3204 do i=is,ie
3205 peln(i,k,j) = log(pe(i,k,j))
3206 pk(i,j,k) = exp( kappa*peln(i,k,j) )
3207 enddo
3208 enddo
3209 enddo
3210
3211 do k=1,npz
3212 do j=js,je
3213 do i=is,ie
3214 delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3215 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3216 q(i,j,k,1) = qs1(k)
3217 enddo
3218 enddo
3219 enddo
3220
3221 k = 1 ! keep the same temperature but adjust the height at the top layer
3222 do j=js,je
3223 do i=is,ie
3224 delz(i,j,k) = rdgas/grav*pt(i,j,k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
3225 enddo
3226 enddo
3227 ! Adjust temperature; enforce constant dz except the top layer
3228 do k=2,npz
3229 do j=js,je
3230 do i=is,ie
3231 delz(i,j,k) = ze1(k+1) - ze1(k)
3232 pt(i,j,k) = delz(i,j,k)*grav/(rdgas*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)))
3233 enddo
3234 enddo
3235 enddo
3236
3237 ! Wind-profile:
3238 do k=1,npz
3239 do j=js,je
3240 do i=is,ie+1
3241 p1(:) = grid(i ,j ,1:2)
3242 p2(:) = grid(i,j+1 ,1:2)
3243 call mid_pt_sphere(p1, p2, p3)
3244 call get_unit_vect2(p1, p2, e2)
3245 call get_latlon_vector(p3, ex, ey)
3246 v(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e2,ex)
3247 enddo
3248 enddo
3249 do j=js,je+1
3250 do i=is,ie
3251 p1(:) = grid(i, j,1:2)
3252 p2(:) = grid(i+1,j,1:2)
3253 call mid_pt_sphere(p1, p2, p3)
3254 call get_unit_vect2(p1, p2, e1)
3255 call get_latlon_vector(p3, ex, ey)
3256 u(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e1,ex)
3257 enddo
3258 enddo
3259 enddo
3260
3261 ! *** Add Initial perturbation ***
3262 if ( test_case == 37 ) then
3263 pp0(1) = pi
3264 pp0(2) = 0.
3265 if (adiabatic) then
3266 pturb = 10.
3267 else
3268 pturb = 3. ! potential temperature
3269 endif
3270 r0 = 10.e3 ! radius
3271 zc = 1.5e3 ! center of bubble from surface
3272 do k=1, npz
3273 zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
3274 ptmp = ( (zm-zc)/zc ) **2
3275 if ( ptmp < 1. ) then
3276 do j=js,je
3277 do i=is,ie
3278 dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
3279 dist = sqrt(dist)
3280 if ( dist < 1. ) then
3281 pt(i,j,k) = pt(i,j,k) + (pkz(i,j,k)/pk0)*pturb*cos(0.5*pi*dist)**2
3282 endif
3283 enddo
3284 enddo
3285 endif
3286 enddo
3287 endif
3288
3289 else if (test_case == 44) then ! Lock-exchange K-H instability on a very large-scale
3290
3291 !Background state
3292 p00 = 1000.e2
3293 ps(:,:) = p00
3294 phis = 0.0
3295 u(:,:,:) = 0.
3296 v(:,:,:) = 0.
3297 q(:,:,:,:) = 0.
3298
3299 if (adiabatic) then
3300 zvir = 0.
3301 else
3302 zvir = rvgas/rdgas - 1.
3303 endif
3304
3305 ! Initialize delta-P
3306 do z=1,npz
3307 do j=js,je
3308 do i=is,ie
3309 delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3310 enddo
3311 enddo
3312 enddo
3313
3314 do j=js,je
3315 do i=is,ie
3316 pe(i,1,j) = ptop
3317 peln(i,1,j) = log(pe(i,1,j))
3318 pk(i,j,1) = exp(kappa*peln(i,1,j))
3319 enddo
3320 do k=2,npz+1
3321 do i=is,ie
3322 pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3323 peln(i,k,j) = log(pe(i,k,j))
3324 pk(i,j,k) = exp(kappa*peln(i,k,j))
3325 enddo
3326 enddo
3327 enddo
3328
3329 p1(1) = pi
3330 p1(2) = 0.
3331 r0 = 1000.e3 ! hurricane size
3332
3333 do k=1,npz
3334 do j=js,je
3335 do i=is,ie
3336 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3337 dist = great_circle_dist( p0, agrid(i,j,1:2), radius )
3338 if ( dist .le. r0 ) then
3339 pt(i,j,k) = 275.
3340 q(i,j,k,1) = 1.
3341 else
3342 pt(i,j,k) = 265.
3343 q(i,j,k,1) = 0.
3344 end if
3345 ! pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3346 enddo
3347 enddo
3348 enddo
3349
3350 if (.not.hydrostatic) then
3351 do k=1,npz
3352 do j=js,je
3353 do i=is,ie
3354 delz(i,j,k) = rdgas*pt(i,j,k)*(1.+zvir*q(i,j,k,1))/grav*log(pe(i,k,j)/pe(i,k+1,j))
3355 w(i,j,k) = 0.0
3356 enddo
3357 enddo
3358 enddo
3359 endif
3360
3361 else if (test_case == 45 .or. test_case == 46) then ! NGGPS test?
3362
3363 ! Background state
3364 f0 = 0.; fC = 0.
3365 pt0 = 300. ! potentil temperature
3366 p00 = 1000.e2
3367 ps(:,:) = p00
3368 phis = 0.0
3369 u(:,:,:) = 0.
3370 v(:,:,:) = 0.
3371 q(:,:,:,:) = 0.
3372
3373 if (adiabatic) then
3374 zvir = 0.
3375 else
3376 zvir = rvgas/rdgas - 1.
3377 endif
3378
3379 ! Initialize delta-P
3380 do k=1,npz
3381 do j=js,je
3382 do i=is,ie
3383 delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
3384 enddo
3385 enddo
3386 enddo
3387
3388 do j=js,je
3389 do i=is,ie
3390 pe(i,1,j) = ptop
3391 peln(i,1,j) = log(pe(i,1,j))
3392 pk(i,j,1) = exp(kappa*peln(i,1,j))
3393 enddo
3394 do k=2,npz+1
3395 do i=is,ie
3396 pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3397 peln(i,k,j) = log(pe(i,k,j))
3398 pk(i,j,k) = exp(kappa*peln(i,k,j))
3399 enddo
3400 enddo
3401 enddo
3402
3403 ! Initiate the westerly-wind-burst:
3404 ubar = soliton_Umax
3405 r0 = soliton_size
3406 !!$ if (test_case == 46) then
3407 !!$ ubar = 200.
3408 !!$ r0 = 250.e3
3409 !!$ else
3410 !!$ ubar = 50. ! Initial maxmium wind speed (m/s)
3411 !!$ r0 = 500.e3
3412 !!$ endif
3413 p0(1) = pi*0.5
3414 p0(2) = 0.
3415
3416 do k=1,npz
3417 do j=js,je
3418 do i=is,ie+1
3419 p1(:) = grid(i ,j ,1:2)
3420 p2(:) = grid(i,j+1 ,1:2)
3421 call mid_pt_sphere(p1, p2, p3)
3422 r = great_circle_dist( p0, p3, radius )
3423 utmp = ubar*exp(-(r/r0)**2)
3424 call get_unit_vect2(p1, p2, e2)
3425 call get_latlon_vector(p3, ex, ey)
3426 v(i,j,k) = utmp*inner_prod(e2,ex)
3427 enddo
3428 enddo
3429 do j=js,je+1
3430 do i=is,ie
3431 p1(:) = grid(i, j,1:2)
3432 p2(:) = grid(i+1,j,1:2)
3433 call mid_pt_sphere(p1, p2, p3)
3434 r = great_circle_dist( p0, p3, radius )
3435 utmp = ubar*exp(-(r/r0)**2)
3436 call get_unit_vect2(p1, p2, e1)
3437 call get_latlon_vector(p3, ex, ey)
3438 u(i,j,k) = utmp*inner_prod(e1,ex)
3439 enddo
3440 enddo
3441
3442 do j=js,je
3443 do i=is,ie
3444 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3445 #ifdef USE_PT
3446 pt(i,j,k) = pt0/p00**kappa
3447 ! Convert back to temperature:
3448 pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3449 #else
3450 pt(i,j,k) = pt0
3451 #endif
3452 q(i,j,k,1) = 0.
3453 enddo
3454 enddo
3455
3456 enddo
3457
3458 #ifdef NEST_TEST
3459 do k=1,npz
3460 do j=js,je
3461 do i=is,ie
3462 q(i,j,k,:) = agrid(i,j,1)*0.180/pi
3463 enddo
3464 enddo
3465 enddo
3466 #else
3467 call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
3468 ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
3469 #endif
3470
3471 if ( .not. hydrostatic ) then
3472 do k=1,npz
3473 do j=js,je
3474 do i=is,ie
3475 delz(i,j,k) = rdgas*pt(i,j,k)/grav*log(pe(i,k,j)/pe(i,k+1,j))
3476 w(i,j,k) = 0.0
3477 enddo
3478 enddo
3479 enddo
3480 endif
3481 else if (test_case == 55 .or. test_case == 56 .or. test_case == 57) then
3482
3483 !Tropical cyclone test case: DCMIP 5X
3484
3485 !test_case 56 initializes the environment
3486 ! but no vortex
3487
3488 !test_case 57 uses a globally-uniform f-plane
3489
3490 ! Initialize surface Pressure
3491 !Vortex perturbation
3492 p0(1) = 180. * pi / 180.
3493 p0(2) = 10. * pi / 180.
3494
3495 if (test_case == 56) then
3496 dp = 0.
3497 rp = 1.e25
3498 else
3499 dp = 1115.
3500 rp = 282000.
3501 endif
3502 p00 = 101500.
3503
3504 ps = p00
3505
3506 do j=js,je
3507 do i=is,ie
3508 p2(:) = agrid(i,j,1:2)
3509 r = great_circle_dist( p0, p2, radius )
3510 ps(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3511 phis(i,j) = 0.
3512 enddo
3513 enddo
3514
3515 call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3516
3517 ! Initialize delta-P
3518 do z=1,npz
3519 do j=js,je
3520 do i=is,ie
3521 delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3522 enddo
3523 enddo
3524 enddo
3525
3526 !Pressure
3527 do j=js,je
3528 do i=is,ie
3529 pe(i,1,j) = ptop
3530 enddo
3531 do k=2,npz+1
3532 do i=is,ie
3533 pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3534 enddo
3535 enddo
3536 enddo
3537
3538 !Pressure on v-grid and u-grid points
3539 do j=js,je
3540 do i=is,ie+1
3541 p2(:) = 0.5*(grid(i,j,1:2)+grid(i,j+1,1:2))
3542 r = great_circle_dist( p0, p2, radius )
3543 ps_v(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3544 enddo
3545 enddo
3546 do j=js,je+1
3547 do i=is,ie
3548 p2(:) = 0.5*(grid(i,j,1:2)+grid(i+1,j,1:2))
3549 r = great_circle_dist( p0, p2, radius )
3550 ps_u(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3551 enddo
3552 enddo
3553
3554 !Pressure
3555 do j=js,je
3556 do i=is,ie+1
3557 pe_v(i,1,j) = ptop
3558 enddo
3559 do k=2,npz+1
3560 do i=is,ie+1
3561 pe_v(i,k,j) = ak(k) + ps_v(i,j)*bk(k)
3562 enddo
3563 enddo
3564 enddo
3565 do j=js,je+1
3566 do i=is,ie
3567 pe_u(i,1,j) = ptop
3568 enddo
3569 do k=2,npz+1
3570 do i=is,ie
3571 pe_u(i,k,j) = ak(k) + ps_u(i,j)*bk(k)
3572 enddo
3573 enddo
3574 enddo
3575
3576 !Everything else
3577 !if (adiabatic) then
3578 ! zvir = 0.
3579 !else
3580 zvir = rvgas/rdgas - 1.
3581 !endif
3582
3583 p0 = (/ pi, pi/18. /)
3584
3585 exppr = 1.5
3586 exppz = 2.
3587 gamma = 0.007
3588 Ts0 = 302.15
3589 q00 = 0.021
3590 t00 = Ts0*(1.+zvir*q00)
3591 exponent = rdgas*gamma/grav
3592 ztrop = 15000.
3593 zp = 7000.
3594 dp = 1115.
3595 cor = 2.*omega*sin(p0(2)) !Coriolis at vortex center
3596
3597 !Initialize winds separately on the D-grid
3598 do j=js,je
3599 do i=is,ie+1
3600 p1(:) = grid(i ,j ,1:2)
3601 p2(:) = grid(i,j+1 ,1:2)
3602 call mid_pt_sphere(p1, p2, p3)
3603 call get_unit_vect2(p1, p2, e2)
3604 call get_latlon_vector(p3, ex, ey)
3605
3606 d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3607 d2 = cos(p0(2))*sin(p3(1)-p0(1))
3608 d = max(1.e-15,sqrt(d1**2+d2**2))
3609
3610 r = great_circle_dist( p0, p3, radius )
3611
3612 do k=1,npz
3613 ptmp = 0.5*(pe_v(i,k,j)+pe_v(i,k+1,j))
3614 height = (t00/gamma)*(1.-(ptmp/ps_v(i,j))**exponent)
3615 if (height > ztrop) then
3616 v(i,j,k) = 0.
3617 else
3618 utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3619 - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3620 /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3621 +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3622 vtmp = utmp*d2
3623 utmp = utmp*d1
3624
3625 v(i,j,k) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
3626
3627 endif
3628 enddo
3629 enddo
3630 enddo
3631 do j=js,je+1
3632 do i=is,ie
3633 p1(:) = grid(i, j,1:2)
3634 p2(:) = grid(i+1,j,1:2)
3635 call mid_pt_sphere(p1, p2, p3)
3636 call get_unit_vect2(p1, p2, e1)
3637 call get_latlon_vector(p3, ex, ey)
3638
3639 d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3640 d2 = cos(p0(2))*sin(p3(1)-p0(1))
3641 d = max(1.e-15,sqrt(d1**2+d2**2))
3642
3643 r = great_circle_dist( p0, p3, radius )
3644
3645 do k=1,npz
3646 ptmp = 0.5*(pe_u(i,k,j)+pe_u(i,k+1,j))
3647 height = (t00/gamma)*(1.-(ptmp/ps_u(i,j))**exponent)
3648 if (height > ztrop) then
3649 v(i,j,k) = 0.
3650 else
3651 utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3652 - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3653 /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3654 +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3655 vtmp = utmp*d2
3656 utmp = utmp*d1
3657
3658 u(i,j,k) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
3659 endif
3660 enddo
3661
3662 enddo
3663 enddo
3664
3665 qtrop = 1.e-11
3666 ttrop = t00 - gamma*ztrop
3667 zq1 = 3000.
3668 zq2 = 8000.
3669
3670 q(:,:,:,:) = 0.
3671
3672 do k=1,npz
3673 do j=js,je
3674 do i=is,ie
3675 ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
3676 height = (t00/gamma)*(1.-(ptmp/ps(i,j))**exponent)
3677 if (height > ztrop) then
3678 q(i,j,k,1) = qtrop
3679 pt(i,j,k) = Ttrop
3680 else
3681 q(i,j,k,1) = q00*exp(-height/zq1)*exp(-(height/zq2)**exppz)
3682 p2(:) = agrid(i,j,1:2)
3683 r = great_circle_dist( p0, p2, radius )
3684 pt(i,j,k) = (T00-gamma*height)/(1.d0+zvir*q(i,j,k,1))/(1.d0+exppz*Rdgas*(T00-gamma*height)*height &
3685 /(grav*zp**exppz*(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz))))
3686 end if
3687 enddo
3688 enddo
3689 enddo
3690
3691 !Note that this is already the moist pressure
3692 do j=js,je
3693 do i=is,ie
3694 ps(i,j) = pe(i,npz+1,j)
3695 enddo
3696 enddo
3697
3698 if (.not.hydrostatic) then
3699 do k=1,npz
3700 do j=js,je
3701 do i=is,ie
3702 delz(i,j,k) = rdgas*pt(i,j,k)*(1.+zvir*q(i,j,k,1))/grav*log(pe(i,k,j)/pe(i,k+1,j))
3703 w(i,j,k) = 0.0
3704 enddo
3705 enddo
3706 enddo
3707 endif
3708
3709 call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
3710
3711 call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3712
3713 if (test_case == 57) then
3714 do j=jsd,jed+1
3715 do i=isd,ied+1
3716 fC(i,j) = cor
3717 enddo
3718 enddo
3719 do j=jsd,jed
3720 do i=isd,ied
3721 f0(i,j) = cor
3722 enddo
3723 enddo
3724 endif
3725
3726
3727 else if ( test_case == -55 ) then
3728
3729 call DCMIP16_TC (delp, pt, u, v, q, w, delz, &
3730 is, ie, js, je, isd, ied, jsd, jed, npz, ncnst, &
3731 ak, bk, ptop, pk, peln, pe, pkz, gz, phis, &
3732 ps, grid, agrid, hydrostatic, nwat, adiabatic)
3733
3734 else
3735
3736 call mpp_error(FATAL, " test_case not defined" )
3737
3738 endif !test_case
3739
3740 call mpp_update_domains( phis, domain )
3741
3742 ftop = g_sum(domain, phis(is:ie,js:je), is, ie, js, je, ng, area, 1)
3743 if(is_master()) write(*,*) 'mean terrain height (m)=', ftop/grav
3744
3745 ! The flow is initially hydrostatic
3746 #ifndef SUPER_K
3747 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3748 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., mountain, &
3749 moist_phys, hydrostatic, nwat, domain, .not.hydrostatic)
3750 #endif
3751
3752 #ifdef COLUMN_TRACER
3753 if( ncnst>1 ) q(:,:,:,2:ncnst) = 0.0
3754 ! Initialize a dummy Column Tracer
3755 pcen(1) = PI/9.
3756 pcen(2) = 2.0*PI/9.
3757 r0 = radius/10.0
3758 do z=1,npz
3759 do j=js,je
3760 do i=is,ie
3761 p1(:) = grid(i ,j ,1:2)
3762 p2(:) = grid(i,j+1 ,1:2)
3763 call mid_pt_sphere(p1, p2, pa)
3764 call get_unit_vect2(p1, p2, e2)
3765 call get_latlon_vector(pa, ex, ey)
3766 ! Perturbation Location Case==13
3767 r = great_circle_dist( pcen, pa, radius )
3768 if (-(r/r0)**2.0 > -40.0) q(i,j,z,1) = EXP(-(r/r0)**2.0)
3769 enddo
3770 enddo
3771 enddo
3772 #endif
3773
3774 #endif
3775 call mp_update_dwinds(u, v, npx, npy, npz, domain)
3776
3777
3778 nullify(agrid)
3779 nullify(grid)
3780
3781 nullify(area)
3782 nullify(rarea)
3783
3784 nullify(fC)
3785 nullify(f0)
3786
3787 nullify(dx)
3788 nullify(dy)
3789 nullify(dxa)
3790 nullify(dya)
3791 nullify(rdxa)
3792 nullify(rdya)
3793 nullify(dxc)
3794 nullify(dyc)
3795
3796 nullify(ee1)
3797 nullify(ee2)
3798 nullify(ew)
3799 nullify(es)
3800 nullify(en1)
3801 nullify(en2)
3802
3803 nullify(latlon)
3804 nullify(cubed_sphere)
3805
3806 nullify(domain)
3807 nullify(tile)
3808
3809 nullify(have_south_pole)
3810 nullify(have_north_pole)
3811
3812 nullify(ntiles_g)
3813 nullify(acapN)
3814 nullify(acapS)
3815 nullify(globalarea)
3816
3817 end subroutine init_case
3818
3819 subroutine get_vorticity(isc, iec, jsc, jec ,isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)
3820 integer isd, ied, jsd, jed, npz
3821 integer isc, iec, jsc, jec
3822 real, intent(in) :: u(isd:ied, jsd:jed+1, npz), v(isd:ied+1, jsd:jed, npz)
3823 real, intent(out) :: vort(isc:iec, jsc:jec, npz)
3824 real, intent(IN) :: dx(isd:ied,jsd:jed+1)
3825 real, intent(IN) :: dy(isd:ied+1,jsd:jed)
3826 real, intent(IN) :: rarea(isd:ied,jsd:jed)
3827 ! Local
3828 real :: utmp(isc:iec, jsc:jec+1), vtmp(isc:iec+1, jsc:jec)
3829 integer :: i,j,k
3830
3831 do k=1,npz
3832 do j=jsc,jec+1
3833 do i=isc,iec
3834 utmp(i,j) = u(i,j,k)*dx(i,j)
3835 enddo
3836 enddo
3837 do j=jsc,jec
3838 do i=isc,iec+1
3839 vtmp(i,j) = v(i,j,k)*dy(i,j)
3840 enddo
3841 enddo
3842
3843 do j=jsc,jec
3844 do i=isc,iec
3845 vort(i,j,k) = rarea(i,j)*(utmp(i,j)-utmp(i,j+1)-vtmp(i,j)+vtmp(i+1,j))
3846 enddo
3847 enddo
3848 enddo
3849
3850 end subroutine get_vorticity
3851
3852 subroutine checker_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3853 nq, km, q, lon, lat, nx, ny, rn)
3854 !--------------------------------------------------------------------
3855 ! This routine computes the checker-board tracer pattern with optional
3856 ! random pertubation (if rn/= 0)
3857 ! To get 20 (deg) by 20 (deg) checker boxes: nx=9, ny=9
3858 ! If random noises are desired, rn=0.1 is a good value
3859 ! lon: longitude (Radian)
3860 ! lat: latitude (Radian)
3861 ! Coded by S.-J. Lin for HIWPP benchmark, Oct2, 2014
3862 !--------------------------------------------------------------------
3863 integer, intent(in):: nq ! number of tracers
3864 integer, intent(in):: km ! vertical dimension
3865 integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3866 integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3867 integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3868 real, intent(in):: nx ! east-west wave number
3869 real, intent(in):: ny ! North-south wave number
3870 real, intent(in), optional:: rn ! (optional) magnitude of random perturbation
3871 real(kind=R_GRID), intent(in), dimension(i0:i1,j0:j1):: lon, lat
3872 real, intent(out):: q(ifirst:ilast,jfirst:jlast,km,nq)
3873 ! Local var:
3874 real:: qt(i0:i1,j0:j1)
3875 real:: qtmp, ftmp
3876 integer:: i,j,k,iq
3877
3878 !$OMP parallel do default(none) shared(i0,i1,j0,j1,nx,lon,ny,lat,qt) &
3879 !$OMP private(qtmp)
3880 do j=j0,j1
3881 do i=i0,i1
3882 qtmp = sin(nx*lon(i,j))*sin(ny*lat(i,j))
3883 if ( qtmp < 0. ) then
3884 qt(i,j) = 0.
3885 else
3886 qt(i,j) = 1.
3887 endif
3888 enddo
3889 enddo
3890
3891 if ( present(rn) ) then ! Add random noises to the set pattern
3892 do iq=1,nq
3893 call random_seed()
3894 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,rn,iq) &
3895 !$OMP private(ftmp)
3896 do k=1,km
3897 do j=j0,j1
3898 do i=i0,i1
3899 call random_number(ftmp)
3900 q(i,j,k,iq) = qt(i,j) + rn*ftmp
3901 enddo
3902 enddo
3903 enddo
3904 enddo
3905 else
3906 do iq=1,nq
3907 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,iq) &
3908 !$OMP private(ftmp)
3909 do k=1,km
3910 do j=j0,j1
3911 do i=i0,i1
3912 q(i,j,k,iq) = qt(i,j)
3913 enddo
3914 enddo
3915 enddo
3916 enddo
3917 endif
3918
3919 end subroutine checker_tracers
3920
3921 subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3922 km, q, delp, ncnst, lon, lat)
3923 !--------------------------------------------------------------------
3924 ! This routine implements the terminator test.
3925 ! Coded by Lucas Harris for DCMIP 2016, May 2016
3926 !--------------------------------------------------------------------
3927 integer, intent(in):: km ! vertical dimension
3928 integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3929 integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3930 integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3931 integer, intent(in):: ncnst
3932 real(kind=R_GRID), intent(in), dimension(ifirst:ilast,jfirst:jlast):: lon, lat
3933 real, intent(inout):: q(ifirst:ilast,jfirst:jlast,km,ncnst)
3934 real, intent(in):: delp(ifirst:ilast,jfirst:jlast,km)
3935 ! Local var:
3936 real:: D, k1, r, ll, sinthc, costhc, mm
3937 integer:: i,j,k
3938 integer:: Cl, Cl2
3939
3940 !NOTE: If you change the reaction rates, then you will have to change it both
3941 ! here and in fv_phys
3942 real, parameter :: qcly = 4.e-6
3943 real, parameter :: lc = 5.*pi/3.
3944 real, parameter :: thc = pi/9.
3945 real, parameter :: k2 = 1.
3946
3947 sinthc = sin(thc)
3948 costhc = cos(thc)
3949
3950 Cl = get_tracer_index (MODEL_ATMOS, 'Cl')
3951 Cl2 = get_tracer_index (MODEL_ATMOS, 'Cl2')
3952
3953 do j=j0,j1
3954 do i=i0,i1
3955 k1 = max(0., sin(lat(i,j))*sinthc + cos(lat(i,j))*costhc*cos(lon(i,j) - lc))
3956 r = k1/k2 * 0.25
3957 D = sqrt(r*r + 2.*r*qcly)
3958 q(i,j,1,Cl) = D - r
3959 q(i,j,1,Cl2) = 0.5*(qcly - q(i,j,1,Cl))
3960 enddo
3961 enddo
3962
3963 do k=2,km
3964 do j=j0,j1
3965 do i=i0,i1
3966 q(i,j,k,Cl) = q(i,j,1,Cl)
3967 q(i,j,k,Cl2) = q(i,j,1,Cl2)
3968 enddo
3969 enddo
3970 enddo
3971
3972 !Compute qcly0
3973 qcly0 = 0.
3974 if (is_master()) then
3975 i = is
3976 j = js
3977 mm = 0.
3978 do k=1,km
3979 qcly0 = qcly0 + (q(i,j,k,Cl) + 2.*q(i,j,k,Cl2))*delp(i,j,k)
3980 mm = mm + delp(i,j,k)
3981 enddo
3982 qcly0 = qcly0/mm
3983 endif
3984 call mpp_sum(qcly0)
3985 if (is_master()) print*, ' qcly0 = ', qcly0
3986
3987
3988 end subroutine terminator_tracers
3989
3990 subroutine rankine_vortex(ubar, r0, p1, u, v, grid )
3991 !----------------------------
3992 ! Rankine vortex
3993 !----------------------------
3994 real, intent(in):: ubar ! max wind (m/s)
3995 real, intent(in):: r0 ! Radius of max wind (m)
3996 real, intent(in):: p1(2) ! center position (longitude, latitude) in radian
3997 real, intent(inout):: u(isd:ied, jsd:jed+1)
3998 real, intent(inout):: v(isd:ied+1,jsd:jed)
3999 real(kind=R_GRID), intent(IN) :: grid(isd:ied+1,jsd:jed+1,2)
4000 ! local:
4001 real(kind=R_GRID):: p2(2), p3(2), p4(2)
4002 real(kind=R_GRID):: e1(3), e2(3), ex(3), ey(3)
4003 real:: vr, r, d2, cos_p, x1, y1
4004 real:: utmp, vtmp
4005 integer i, j
4006
4007 ! Compute u-wind
4008 do j=js,je+1
4009 do i=is,ie
4010 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
4011 ! shift:
4012 p2(1) = p2(1) - p1(1)
4013 cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
4014 r = radius*acos(cos_p) ! great circle distance
4015 ! if( r<0.) call mpp_error(FATAL, 'radius negative!')
4016 if( r<r0 ) then
4017 vr = ubar*r/r0
4018 else
4019 vr = ubar*r0/r
4020 endif
4021 x1 = cos(p2(2))*sin(p2(1))
4022 y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
4023 d2 = max(1.e-25, sqrt(x1**2 + y1**2))
4024 utmp = -vr*y1/d2
4025 vtmp = vr*x1/d2
4026 p3(1) = grid(i,j, 1) - p1(1)
4027 p3(2) = grid(i,j, 2)
4028 p4(1) = grid(i+1,j,1) - p1(1)
4029 p4(2) = grid(i+1,j,2)
4030 call get_unit_vect2(p3, p4, e1)
4031 call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
4032 u(i,j) = u(i,j) + utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
4033 enddo
4034 enddo
4035
4036 ! Compute v-wind
4037 do j=js,je
4038 do i=is,ie+1
4039 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
4040 ! shift:
4041 p2(1) = p2(1) - p1(1)
4042 cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
4043 r = radius*acos(cos_p) ! great circle distance
4044 if( r<r0 ) then
4045 vr = ubar*r/r0
4046 else
4047 vr = ubar*r0/r
4048 endif
4049 x1 = cos(p2(2))*sin(p2(1))
4050 y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
4051 d2 = max(1.e-25, sqrt(x1**2 + y1**2))
4052 utmp = -vr*y1/d2
4053 vtmp = vr*x1/d2
4054 p3(1) = grid(i,j, 1) - p1(1)
4055 p3(2) = grid(i,j, 2)
4056 p4(1) = grid(i,j+1,1) - p1(1)
4057 p4(2) = grid(i,j+1,2)
4058 call get_unit_vect2(p3, p4, e2)
4059 call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
4060 v(i,j) = v(i,j) + utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
4061 enddo
4062 enddo
4063 end subroutine rankine_vortex
4064
4065
4066
4067 real function gh_jet(npy, lat_in)
4068 integer, intent(in):: npy
4069 real, intent(in):: lat_in
4070 real lat, lon, dp, uu
4071 real h0, ft
4072 integer j,jm
4073
4074 jm = 4 * npy
4075 ! h0 = 10.E3
4076 h0 = 10.157946867E3
4077 dp = pi / real(jm-1)
4078
4079 if ( .not. gh_initialized ) then
4080 ! SP:
4081 allocate(gh_table(jm))
4082 allocate(lats_table(jm))
4083 gh_table(1) = grav*h0
4084 lats_table(1) = -pi/2.
4085 ! Using only the mid-point for integration
4086 do j=2,jm
4087 lat = -pi/2. + (real(j-1)-0.5)*dp
4088 uu = u_jet(lat)
4089 ft = 2.*omega*sin(lat)
4090 gh_table(j) = gh_table(j-1) - uu*(radius*ft + tan(lat)*uu) * dp
4091 lats_table(j) = -pi/2. + real(j-1)*dp
4092 enddo
4093 gh_initialized = .true.
4094 endif
4095
4096 if ( lat_in <= lats_table(1) ) then
4097 gh_jet = gh_table(1)
4098 return
4099 endif
4100 if ( lat_in >= lats_table(jm) ) then
4101 gh_jet = gh_table(jm)
4102 return
4103 endif
4104
4105 ! Search:
4106 do j=1,jm-1
4107 if ( lat_in >=lats_table(j) .and. lat_in<=lats_table(j+1) ) then
4108 gh_jet = gh_table(j) + (gh_table(j+1)-gh_table(j))/dp * (lat_in-lats_table(j))
4109 return
4110 endif
4111 enddo
4112 end function gh_jet
4113
4114 real function u_jet(lat)
4115 real lat, lon, dp
4116 real umax, en, ph0, ph1
4117
4118 umax = 80.
4119 ph0 = pi/7.
4120 ph1 = pi/2. - ph0
4121 en = exp( -4./(ph1-ph0)**2 )
4122
4123 if ( lat>ph0 .and. lat<ph1 ) then
4124 u_jet = (umax/en)*exp( 1./( (lat-ph0)*(lat-ph1) ) )
4125 else
4126 u_jet = 0.
4127 endif
4128 end function u_jet
4129
4130 subroutine get_case9_B(B, agrid)
4131 real, intent(OUT) :: B(isd:ied,jsd:jed)
4132 real, intent(IN) :: agrid(isd:ied,jsd:jed,2)
4133 real :: myC,yy,myB
4134 integer :: i,j
4135 ! Generate B forcing function
4136 !
4137 gh0 = 720.*grav
4138 do j=jsd,jed
4139 do i=isd,ied
4140 if (sin(agrid(i,j,2)) > 0.) then
4141 myC = sin(agrid(i,j,1))
4142 yy = (cos(agrid(i,j,2))/sin(agrid(i,j,2)))**2
4143 myB = gh0*yy*exp(1.-yy)
4144 B(i,j) = myB*myC
4145 else
4146 B(i,j) = 0.
4147 endif
4148 enddo
4149 enddo
4150
4151 end subroutine get_case9_B
4152 !
4153 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4154 !-------------------------------------------------------------------------------
4155
4156 !-------------------------------------------------------------------------------
4157 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4158 !
4159 subroutine case9_forcing1(phis,time_since_start)
4160
4161 real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4162 real , intent(IN) :: time_since_start
4163 real :: tday, amean
4164 integer :: i,j
4165 !
4166 ! Generate B forcing function
4167 !
4168 tday = time_since_start/86400.0
4169 if (tday >= 20.) then
4170 AofT(2) = 0.5*(1.-cos(0.25*PI*(tday-20)))
4171 if (tday == 24) AofT(2) = 1.0
4172 elseif (tday <= 4.) then
4173 AofT(2) = 0.5*(1.-cos(0.25*PI*tday))
4174 elseif (tday <= 16.) then
4175 AofT(2) = 1.
4176 else
4177 AofT(2) = 0.5*(1.+cos(0.25*PI*(tday-16.)))
4178 endif
4179 amean = 0.5*(AofT(1)+AofT(2))
4180 do j=jsd,jed
4181 do i=isd,ied
4182 phis(i,j) = amean*case9_B(i,j)
4183 enddo
4184 enddo
4185
4186 end subroutine case9_forcing1
4187 !
4188 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4189 !-------------------------------------------------------------------------------
4190
4191 !-------------------------------------------------------------------------------
4192 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4193 !
4194 subroutine case9_forcing2(phis)
4195 real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4196 integer :: i,j
4197 !
4198 ! Generate B forcing function
4199 !
4200 do j=jsd,jed
4201 do i=isd,ied
4202 phis(i,j) = AofT(2)*case9_B(i,j)
4203 enddo
4204 enddo
4205 AofT(1) = AofT(2)
4206
4207 end subroutine case9_forcing2
4208 !
4209 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4210 !-------------------------------------------------------------------------------
4211
4212 subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain)
4213
4214 real, intent(INOUT) :: delp(isd:ied,jsd:jed,npz)
4215 real, intent(INOUT) :: uc(isd:ied+1,jsd:jed,npz)
4216 real, intent(INOUT) :: vc(isd:ied,jsd:jed+1,npz)
4217 real, intent(INOUT) :: u(isd:ied,jsd:jed+1,npz)
4218 real, intent(INOUT) :: v(isd:ied+1,jsd:jed,npz)
4219 real, intent(INOUT) :: ua(isd:ied,jsd:jed,npz)
4220 real, intent(INOUT) :: va(isd:ied,jsd:jed,npz)
4221 real, intent(INOUT) :: pe(is-1:ie+1, npz+1,js-1:je+1) ! edge pressure (pascal)
4222 real, intent(IN) :: time, dt
4223 real, intent(INOUT) :: ptop
4224 integer, intent(IN) :: npx, npy, npz
4225 type(fv_grid_type), intent(IN), target :: gridstruct
4226 type(domain2d), intent(INOUT) :: domain
4227
4228 real :: period
4229 real :: omega0
4230
4231 integer :: i,j,k
4232
4233 real :: s, l, dt2, V0, phase
4234 real :: ull, vll, lonp
4235 real :: p0(2), elon(3), elat(3)
4236
4237 real :: psi(isd:ied,jsd:jed)
4238 real :: psi_b(isd:ied+1,jsd:jed+1)
4239 real :: dist, psi1, psi2
4240
4241 real :: k_cell = 5
4242
4243 real :: utmp, vtmp
4244 real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3), pt(2), p1(2), p2(2), p3(2), rperiod, timefac, t00
4245
4246 integer :: wind_field = 1 !Should be the same as tracer_test
4247
4248 real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
4249 real, pointer, dimension(:,:) :: dx, dxa, dy, dya, dxc, dyc
4250
4251 agrid => gridstruct%agrid_64
4252 grid => gridstruct%grid_64
4253
4254 dx => gridstruct%dx
4255 dxa => gridstruct%dxa
4256 dxc => gridstruct%dxc
4257 dy => gridstruct%dy
4258 dya => gridstruct%dya
4259 dyc => gridstruct%dyc
4260
4261 period = real( 12*24*3600 ) !12 days
4262
4263 l = 2.*pi/period
4264 dt2 = dt*0.5
4265
4266 phase = pi*time/period
4267
4268 !call prt_maxmin('pe', pe, is, ie, js, je, 0, npz, 1.E-3)
4269
4270 !Winds: NONDIVERGENT---just use streamfunction!
4271
4272 psi(:,:) = 1.e25
4273 psi_b(:,:) = 1.e25
4274
4275
4276 select case (wind_field)
4277 case (0)
4278
4279 omega0 = 23000.*pi/period
4280
4281 t00 = 300.
4282 ptop = 100000.*exp(-12000.*grav/t00/rdgas)
4283
4284 do j=js,je
4285 do k=1,npz+1
4286 do i=is,ie
4287 s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4288 pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4289 cos(period*(time+dt2))*sin(s*0.5*pi)
4290 enddo
4291 enddo
4292 enddo
4293
4294 do k=1,npz
4295 do j=js,je
4296 do i=is,ie
4297 delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4298 enddo
4299 enddo
4300 enddo
4301
4302 v0 = 10.*RADIUS/period !k in DCMIP document
4303 ubar = 40.
4304
4305 do j=jsd,jed
4306 do i=isd,ied
4307 psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
4308 cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
4309 enddo
4310 enddo
4311 call mpp_update_domains( psi, domain )
4312 do j=jsd,jed+1
4313 do i=isd,ied+1
4314 psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
4315 cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
4316 enddo
4317 enddo
4318
4319 k = 1
4320
4321 do j=js,je+1
4322 do i=is,ie
4323 dist = dx(i,j)
4324 vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
4325 if (dist==0) vc(i,j,k) = 0.
4326 enddo
4327 enddo
4328 do j=js,je
4329 do i=is,ie+1
4330 dist = dy(i,j)
4331 uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
4332 if (dist==0) uc(i,j,k) = 0.
4333 enddo
4334 enddo
4335
4336 do j=js,je
4337 do i=is,ie+1
4338 dist = dxc(i,j)
4339 v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
4340 if (dist==0) v(i,j,k) = 0.
4341 enddo
4342 enddo
4343 do j=js,je+1
4344 do i=is,ie
4345 dist = dyc(i,j)
4346 u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
4347 if (dist==0) u(i,j,k) = 0.
4348 enddo
4349 enddo
4350
4351 do j=js,je
4352 do i=is,ie
4353 psi1 = 0.5*(psi(i,j)+psi(i,j-1))
4354 psi2 = 0.5*(psi(i,j)+psi(i,j+1))
4355 dist = dya(i,j)
4356 ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
4357 if (dist==0) ua(i,j,k) = 0.
4358 psi1 = 0.5*(psi(i,j)+psi(i-1,j))
4359 psi2 = 0.5*(psi(i,j)+psi(i+1,j))
4360 dist = dxa(i,j)
4361 va(i,j,k) = (psi2 - psi1) / (dist)
4362 if (dist==0) va(i,j,k) = 0.
4363 enddo
4364 enddo
4365
4366 case (1)
4367
4368 omega0 = 23000.*pi/period
4369
4370 do j=js,je
4371 do k=1,npz+1
4372 do i=is,ie
4373 s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4374 pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4375 cos(period*(time+dt2))*sin(s*0.5*pi)
4376 enddo
4377 enddo
4378 enddo
4379
4380 do k=1,npz
4381 do j=js,je
4382 do i=is,ie
4383 delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4384 enddo
4385 enddo
4386 enddo
4387
4388 ubar = 10.*RADIUS/period !k in DCMIP document
4389
4390
4391 do j=js,je
4392 do i=is,ie+1
4393 p1(:) = grid(i ,j ,1:2)
4394 p2(:) = grid(i,j+1 ,1:2)
4395 call mid_pt_sphere(p1, p2, p3)
4396 call get_unit_vect2(p1, p2, e2) !! e2 is WRONG in halo??
4397 call get_latlon_vector(p3, ex, ey)
4398 l = p3(1) - 2.*pi*time/period
4399 utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*RADIUS/period*cos(p3(2))
4400 vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4401 v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
4402 enddo
4403 enddo
4404 do j=js,je+1
4405 do i=is,ie
4406 p1(:) = grid(i, j,1:2)
4407 p2(:) = grid(i+1,j,1:2)
4408 call mid_pt_sphere(p1, p2, p3)
4409 call get_unit_vect2(p1, p2, e1)
4410 call get_latlon_vector(p3, ex, ey)
4411 l = p3(1) - 2.*pi*time/period
4412 utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*RADIUS/period*cos(p3(2))
4413 vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4414 u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
4415 enddo
4416 enddo
4417
4418 call mp_update_dwinds(u(:,:,1), v(:,:,1), npx, npy, domain)
4419
4420 ! copy vertically; no wind shear
4421 do k=2,npz
4422 do j=jsd,jed+1
4423 do i=isd,ied
4424 u(i,j,k) = u(i,j,1)
4425 enddo
4426 enddo
4427 do j=jsd,jed
4428 do i=isd,ied+1
4429 v(i,j,k) = v(i,j,1)
4430 enddo
4431 enddo
4432 enddo
4433
4434 call mp_update_dwinds(u, v, npx, npy, npz, domain)
4435
4436 call dtoa( u(:,:,1), v(:,:,1),ua(:,:,1),va(:,:,1),dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
4437 call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM) !! ABSOLUTELY NECESSARY!!
4438 call atoc(ua(:,:,1),va(:,:,1),uc(:,:,1),vc(:,:,1),dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
4439
4440 do k=2,npz
4441 do j=js,je
4442 do i=is,ie
4443 ua(i,j,k) = ua(i,j,1)
4444 enddo
4445 enddo
4446 do j=js,je
4447 do i=is,ie
4448 va(i,j,k) = va(i,j,1)
4449 enddo
4450 enddo
4451 enddo
4452
4453 do k=2,npz
4454 do j=js,je+1
4455 do i=is,ie
4456 vc(i,j,k) = vc(i,j,1)
4457 enddo
4458 enddo
4459 do j=js,je
4460 do i=is,ie+1
4461 uc(i,j,k) = uc(i,j,1)
4462 enddo
4463 enddo
4464 enddo
4465
4466 !cases 2 and 3 are not nondivergent so we cannot use a streamfunction.
4467 case (2)
4468
4469 omega0 = 0.25
4470
4471 do j=js,je
4472 do k=1,npz+1
4473 do i=is,ie
4474 pe(i,k,j) = pe(i,k,j) + dt*omega0*grav*pe(i,k,j)/rdgas/300./k_cell* &
4475 (-2.*sin(k_cell*agrid(i,j,2))*sin(agrid(i,j,2)) + k_cell*cos(agrid(i,j,2))*cos(k_cell*agrid(i,j,2)))* &
4476 sin(pi*zz0(k)/12000.)*cos(phase)
4477 enddo
4478 enddo
4479 enddo
4480
4481 do k=1,npz
4482 do j=js,je
4483 do i=is,ie
4484 delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4485 enddo
4486 enddo
4487 enddo
4488
4489 ubar = 40.
4490
4491 !Set lat-lon A-grid winds
4492 k = 1
4493 do j=js,je
4494 do i=is,ie
4495 utmp = ubar*cos(agrid(i,j,2))
4496 vtmp = - RADIUS * omega0 * pi / k_cell / 12000. * &
4497 cos(agrid(i,j,2)) * sin(k_cell * agrid(i,j,2)) * &
4498 sin(pi*zz0(k)/12000.)*cos(phase)
4499 enddo
4500 enddo
4501
4502 end select
4503
4504 do k=2,npz
4505 u(:,:,k) = u(:,:,1)
4506 v(:,:,k) = v(:,:,1)
4507 uc(:,:,k) = uc(:,:,1)
4508 vc(:,:,k) = vc(:,:,1)
4509 ua(:,:,k) = ua(:,:,1)
4510 va(:,:,k) = va(:,:,1)
4511 enddo
4512
4513 call mpp_update_domains( uc, vc, domain, gridtype=CGRID_NE_PARAM)
4514 call fill_corners(uc, vc, npx, npy, npz, VECTOR=.true., CGRID=.true.)
4515 call mp_update_dwinds(u, v, npx, npy, npz, domain)
4516
4517 nullify(agrid)
4518 nullify(grid)
4519
4520 nullify(dx)
4521 nullify(dxa)
4522 nullify(dy)
4523 nullify(dya)
4524
4525 end subroutine case51_forcing
4526
4527 !-------------------------------------------------------------------------------
4528 !
4529 ! get_stats :: get L-1, L-2, and L-inf norms and other stats as defined
4530 ! in Williamson, 1994 (p.16)
4531 subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, &
4532 uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions, &
4533 gridstruct, stats_lun, consv_lun, monitorFreq, tile, &
4534 domain, nested)
4535 integer, intent(IN) :: nt, maxnt
4536 real , intent(IN) :: dt, dtout, ndays
4537 real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
4538 real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
4539 real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
4540 real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
4541 real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
4542 real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4543 real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
4544 real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
4545 real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
4546 real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
4547 real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
4548 integer, intent(IN) :: npx, npy, npz, ncnst, tile
4549 integer, intent(IN) :: ndims
4550 integer, intent(IN) :: nregions
4551 integer, intent(IN) :: stats_lun
4552 integer, intent(IN) :: consv_lun
4553 integer, intent(IN) :: monitorFreq
4554 type(fv_grid_type), target :: gridstruct
4555 type(domain2d), intent(INOUT) :: domain
4556 logical, intent(IN) :: nested
4557
4558 real :: L1_norm
4559 real :: L2_norm
4560 real :: Linf_norm
4561 real :: pmin, pmin1, uamin1, vamin1
4562 real :: pmax, pmax1, uamax1, vamax1
4563 real(kind=4) :: arr_r4(5)
4564 real :: tmass0, tvort0, tener0, tKE0
4565 real :: tmass, tvort, tener, tKE
4566 real :: temp(is:ie,js:je)
4567 integer :: i0, j0, k0, n0
4568 integer :: i, j, k, n, iq
4569
4570 real :: psmo, Vtx, p, w_p, p0
4571 real :: x1,y1,z1,x2,y2,z2,ang
4572
4573 real :: p1(2), p2(2), p3(2), r, r0, dist, heading
4574
4575 real :: uc0(isd:ied+1,jsd:jed ,npz)
4576 real :: vc0(isd:ied ,jsd:jed+1,npz)
4577
4578 real :: myDay
4579 integer :: myRec
4580
4581 real, save, allocatable, dimension(:,:,:) :: u0, v0
4582 real :: up(isd:ied ,jsd:jed+1,npz)
4583 real :: vp(isd:ied+1,jsd:jed ,npz)
4584
4585 real, dimension(:,:,:), pointer :: grid, agrid
4586 real, dimension(:,:), pointer :: area, f0, dx, dy, dxa, dya, dxc, dyc
4587
4588 grid => gridstruct%grid
4589 agrid=> gridstruct%agrid
4590
4591 area => gridstruct%area
4592 f0 => gridstruct%f0
4593
4594 dx => gridstruct%dx
4595 dy => gridstruct%dy
4596 dxa => gridstruct%dxa
4597 dya => gridstruct%dya
4598 dxc => gridstruct%dxc
4599 dyc => gridstruct%dyc
4600
4601 !!! DEBUG CODE
4602 if (nt == 0 .and. is_master()) print*, 'INITIALIZING GET_STATS'
4603 !!! END DEBUG CODE
4604
4605 myDay = ndays*((FLOAT(nt)/FLOAT(maxnt)))
4606
4607 #if defined(SW_DYNAMICS)
4608 if (test_case==0) then
4609 phi0 = 0.0
4610 do j=js,je
4611 do i=is,ie
4612 x1 = agrid(i,j,1)
4613 y1 = agrid(i,j,2)
4614 z1 = radius
4615 p = p0_c0 * cos(y1)
4616 Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
4617 w_p = 0.0
4618 if (p /= 0.0) w_p = Vtx/p
4619 ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4620 phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4621 enddo
4622 enddo
4623 elseif (test_case==1) then
4624 ! Get Current Height Field "Truth"
4625 p1(1) = pi/2. + pi_shift
4626 p1(2) = 0.
4627 p2(1) = 3.*pi/2. + pi_shift
4628 p2(2) = 0.
4629 r0 = radius/3. !RADIUS 3.
4630 dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
4631 heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha
4632 call get_pt_on_great_circle( p1, p2, dist, heading, p3)
4633 phi0 = 0.0
4634 do j=js,je
4635 do i=is,ie
4636 p2(1) = agrid(i,j,1)
4637 p2(2) = agrid(i,j,2)
4638 r = great_circle_dist( p3, p2, radius )
4639 if (r < r0) then
4640 phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
4641 else
4642 phi0(i,j,1) = phis(i,j)
4643 endif
4644 enddo
4645 enddo
4646 endif
4647
4648 ! Get Height Field Stats
4649 call pmxn(delp(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4650 pmin1=pmin1/Grav
4651 pmax1=pmax1/Grav
4652 if (test_case <= 2) then
4653 call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, &
4654 pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
4655 pmin=pmin/Grav
4656 pmax=pmax/Grav
4657 arr_r4(1) = pmin1
4658 arr_r4(2) = pmax1
4659 arr_r4(3) = L1_norm
4660 arr_r4(4) = L2_norm
4661 arr_r4(5) = Linf_norm
4662 !if (is_master()) write(stats_lun,rec=(nt)*2 + 1) arr_r4
4663 else
4664 arr_r4(1) = pmin1
4665 arr_r4(2) = pmax1
4666 arr_r4(3:5) = 0.
4667 pmin = 0.
4668 pmax = 0.
4669 L1_norm = 0.
4670 L2_norm = 0.
4671 Linf_norm = 0.
4672 endif
4673
4674 200 format(i6.6,A,i6.6,A,e21.14)
4675 201 format(' ',A,e21.14,' ',e21.14)
4676 202 format(' ',A,i4.4,'x',i4.4,'x',i4.4)
4677
4678 if ( (is_master()) .and. MOD(nt,monitorFreq)==0 ) then
4679 write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay
4680 write(*,201) 'Height MAX : ', pmax1
4681 write(*,201) 'Height MIN : ', pmin1
4682 write(*,202) 'HGT MAX location : ', i0, j0, n0
4683 if (test_case <= 2) then
4684 write(*,201) 'Height L1_norm : ', L1_norm
4685 write(*,201) 'Height L2_norm : ', L2_norm
4686 write(*,201) 'Height Linf_norm : ', Linf_norm
4687 endif
4688 endif
4689
4690 ! Get UV Stats
4691 call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
4692 call pmxn(ua(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4693 if (test_case <= 2) then
4694 call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, &
4695 pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
4696 endif
4697 arr_r4(1) = pmin1
4698 arr_r4(2) = pmax1
4699 arr_r4(3) = L1_norm
4700 arr_r4(4) = L2_norm
4701 arr_r4(5) = Linf_norm
4702 !if (is_master()) write(stats_lun,rec=(nt)*2 + 2) arr_r4
4703 if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then
4704 write(*,201) 'UV MAX : ', pmax1
4705 write(*,201) 'UV MIN : ', pmin1
4706 write(*,202) 'UV MAX location : ', i0, j0, n0
4707 if (test_case <= 2) then
4708 write(*,201) 'UV L1_norm : ', L1_norm
4709 write(*,201) 'UV L2_norm : ', L2_norm
4710 write(*,201) 'UV Linf_norm : ', Linf_norm
4711 endif
4712 endif
4713 #else
4714
4715 200 format(i6.6,A,i6.6,A,e10.4)
4716 201 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4717 202 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4)
4718 203 format(' ',A,i3.3,A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4719
4720 if(is_master()) write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay
4721
4722 ! Surface Pressure
4723 psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4724 if(is_master()) write(*,*) ' Total surface pressure =', 0.01*psmo
4725 call pmxn(ps, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4726 if (is_master()) then
4727 write(*,201) 'PS MAX|MIN : ', 0.01*pmax, 0.01*pmin, i0, j0, n0
4728 endif
4729
4730 ! Get PT Stats
4731 pmax1 = -1.e25
4732 pmin1 = 1.e25
4733 i0=-999
4734 j0=-999
4735 k0=-999
4736 n0=-999
4737 do k=1,npz
4738 call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4739 pmin1 = min(pmin, pmin1)
4740 pmax1 = max(pmax, pmax1)
4741 if (pmax1 == pmax) k0 = k
4742 enddo
4743 if (is_master()) then
4744 write(*,201) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4745 endif
4746
4747 #if defined(DEBUG_TEST_CASES)
4748 if(is_master()) write(*,*) ' '
4749 do k=1,npz
4750 pmax1 = -1.e25
4751 pmin1 = 1.e25
4752 i0=-999
4753 j0=-999
4754 k0=-999
4755 n0=-999
4756 call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4757 pmin1 = min(pmin, pmin1)
4758 pmax1 = max(pmax, pmax1)
4759 if (is_master()) then
4760 write(*,202) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k, n0, 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) )
4761 endif
4762 enddo
4763 if(is_master()) write(*,*) ' '
4764 #endif
4765
4766 ! Get DELP Stats
4767 pmax1 = -1.e25
4768 pmin1 = 1.e25
4769 i0=-999
4770 j0=-999
4771 k0=-999
4772 n0=-999
4773 do k=1,npz
4774 call pmxn(delp(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4775 pmin1 = min(pmin, pmin1)
4776 pmax1 = max(pmax, pmax1)
4777 if (pmax1 == pmax) k0 = k
4778 enddo
4779 if (is_master()) then
4780 write(*,201) 'Delp MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4781 endif
4782
4783 ! Get UV Stats
4784 uamax1 = -1.e25
4785 uamin1 = 1.e25
4786 i0=-999
4787 j0=-999
4788 k0=-999
4789 n0=-999
4790 do k=1,npz
4791 call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
4792 call pmxn(ua(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4793 uamin1 = min(pmin, uamin1)
4794 uamax1 = max(pmax, uamax1)
4795 if (uamax1 == pmax) k0 = k
4796 enddo
4797 if (is_master()) then
4798 write(*,201) 'U MAX|MIN : ', uamax1, uamin1, i0, j0, k0, n0
4799 endif
4800
4801 vamax1 = -1.e25
4802 vamin1 = 1.e25
4803 i0=-999
4804 j0=-999
4805 k0=-999
4806 n0=-999
4807 do k=1,npz
4808 call pmxn(va(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4809 vamin1 = min(pmin, vamin1)
4810 vamax1 = max(pmax, vamax1)
4811 if (vamax1 == pmax) k0 = k
4812 enddo
4813 if (is_master()) then
4814 write(*,201) 'V MAX|MIN : ', vamax1, vamin1, i0, j0, k0, n0
4815 endif
4816
4817 ! Get Q Stats
4818 pmax1 = -1.e25
4819 pmin1 = 1.e25
4820 i0=-999
4821 j0=-999
4822 k0=-999
4823 n0=-999
4824 do k=1,npz
4825 call pmxn(q(isd,jsd,k,1), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4826 pmin1 = min(pmin, pmin1)
4827 pmax1 = max(pmax, pmax1)
4828 if (pmax1 == pmax) k0 = k
4829 enddo
4830 if (is_master()) then
4831 write(*,201) 'Q MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4832 endif
4833
4834 ! Get tracer Stats
4835 do iq=2,ncnst
4836 pmax1 = -1.e25
4837 pmin1 = 1.e25
4838 i0=-999
4839 j0=-999
4840 k0=-999
4841 n0=-999
4842 do k=1,npz
4843 call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4844 pmin1 = min(pmin, pmin1)
4845 pmax1 = max(pmax, pmax1)
4846 if (pmax1 == pmax) k0 = k
4847 enddo
4848 if (is_master()) then
4849 write(*,203) 'TR',iq-1,' MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4850 endif
4851 enddo
4852
4853 #endif
4854
4855 if (test_case == 12) then
4856 ! Get UV Stats
4857 call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, &
4858 pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
4859 if (is_master()) then
4860 write(*,201) 'UV(850) L1_norm : ', L1_norm
4861 write(*,201) 'UV(850) L2_norm : ', L2_norm
4862 write(*,201) 'UV(850) Linf_norm : ', Linf_norm
4863 endif
4864 endif
4865
4866 tmass = 0.0
4867 tKE = 0.0
4868 tener = 0.0
4869 tvort = 0.0
4870 #if defined(SW_DYNAMICS)
4871 do k=1,1
4872 #else
4873 do k=1,npz
4874 #endif
4875 ! Get conservation Stats
4876
4877 ! Conservation of Mass
4878 temp(:,:) = delp(is:ie,js:je,k)
4879 tmass0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4880 tmass = tmass + tmass0
4881
4882 !if (.not. allocated(u0, v0)) then
4883 if (nt == 0) then
4884 allocate(u0(isd:ied,jsd:jed+1,npz))
4885 allocate(v0(isd:ied+1,jsd:jed,npz))
4886 u0 = u
4887 v0 = v
4888 endif
4889
4890 !! UA is the PERTURBATION now
4891 up = u - u0
4892 vp = v - v0
4893
4894 call dtoa(up(isd,jsd,k), vp(isd,jsd,k), ua, va, dx,dy, dxa, dya, dxc, dyc, npx, npy, ng)
4895 call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),dx,dy,dxa,dya,npx,npy,ng,nested, domain, noComm=.true.)
4896 ! Conservation of Kinetic Energy
4897 do j=js,je
4898 do i=is,ie
4899 temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + &
4900 vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) )
4901 enddo
4902 enddo
4903 tKE0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4904 tKE = tKE + tKE0
4905
4906 ! Conservation of Energy
4907 do j=js,je
4908 do i=is,ie
4909 temp(i,j) = 0.5 * (delp(i,j,k)/Grav) * temp(i,j) ! Include Previously calcullated KE
4910 temp(i,j) = temp(i,j) + &
4911 Grav*((delp(i,j,k)/Grav + phis(i,j))*(delp(i,j,k)/Grav + phis(i,j))) - &
4912 phis(i,j)*phis(i,j)
4913 enddo
4914 enddo
4915 tener0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4916 tener = tener + tener0
4917
4918 ! Conservation of Potential Enstrophy
4919 if (test_case>1) then
4920 do j=js,je
4921 do i=is,ie
4922 temp(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - &
4923 (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
4924 temp(i,j) = ( Grav*(temp(i,j)*temp(i,j))/delp(i,j,k) )
4925 enddo
4926 enddo
4927 tvort0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4928 tvort = tvort + tvort0
4929 else
4930 tvort=1.
4931 endif
4932 enddo
4933
4934 if (nt == 0) then
4935 tmass_orig = tmass
4936 tener_orig = tener
4937 tvort_orig = tvort
4938 endif
4939 arr_r4(1) = (tmass-tmass_orig)/tmass_orig
4940 arr_r4(2) = (tener-tener_orig)/tener_orig
4941 arr_r4(3) = (tvort-tvort_orig)/tvort_orig
4942 arr_r4(4) = tKE
4943 if (test_case==12) arr_r4(4) = L2_norm
4944 #if defined(SW_DYNAMICS)
4945 myRec = nt+1
4946 #else
4947 myRec = myDay*86400.0/dtout + 1
4948 #endif
4949 if (is_master()) write(consv_lun,rec=myRec) arr_r4(1:4)
4950 #if defined(SW_DYNAMICS)
4951 if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then
4952 #else
4953 if ( (is_master()) ) then
4954 #endif
4955 write(*,201) 'MASS TOTAL : ', tmass
4956 write(*,201) 'NORMALIZED MASS : ', (tmass-tmass_orig)/tmass_orig
4957 if (test_case >= 2) then
4958 write(*,201) 'Kinetic Energy KE : ', tKE
4959 write(*,201) 'ENERGY TOTAL : ', tener
4960 write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig
4961 write(*,201) 'ENSTR TOTAL : ', tvort
4962 write(*,201) 'NORMALIZED ENSTR : ', (tvort-tvort_orig)/tvort_orig
4963 endif
4964 write(*,*) ' '
4965 endif
4966
4967 nullify(grid)
4968 nullify(agrid)
4969 nullify(area)
4970 nullify(f0)
4971 nullify(dx)
4972 nullify(dy)
4973
4974 end subroutine get_stats
4975
4976
4977
4978 subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3)
4979 ! get_pt_on_great_circle :: Get the mid-point on a great circle given:
4980 ! -2 points (Lon/Lat) to define a great circle
4981 ! -Great Cirle distance between 2 defining points
4982 ! -Heading
4983 ! compute:
4984 ! Arrival Point (Lon/Lat)
4985
4986 real , intent(IN) :: p1(2), p2(2)
4987 real , intent(IN) :: dist
4988 real , intent(IN) :: heading
4989 real , intent(OUT) :: p3(2)
4990
4991 real pha, dp
4992
4993 pha = dist/radius
4994
4995 p3(2) = ASIN( (COS(heading)*COS(p1(2))*SIN(pha)) + (SIN(p1(2))*COS(pha)) )
4996 dp = ATAN2( SIN(heading)*SIN(pha)*COS(p1(2)) , COS(pha) - SIN(p1(2))*SIN(p3(2)) )
4997 p3(1) = MOD( (p1(1)-pi)-dp+pi , 2.*pi ) !- pi Leave at 0 to 360
4998
4999 end subroutine get_pt_on_great_circle
5000
5001
5002 !
5003 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5004 !-------------------------------------------------------------------------------
5005
5006 !-------------------------------------------------------------------------------
5007 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5008 !
5009 ! get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
5010 ! in Williamson, 1994 (p.16)
5011 ! for any var
5012
5013 subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, &
5014 vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
5015 integer, intent(IN) :: npx, npy
5016 integer, intent(IN) :: ndims
5017 integer, intent(IN) :: nregions, tile
5018 real , intent(IN) :: var(isd:ied,jsd:jed)
5019 real , intent(IN) :: varT(isd:ied,jsd:jed)
5020 real , intent(OUT) :: vmin
5021 real , intent(OUT) :: vmax
5022 real , intent(OUT) :: L1_norm
5023 real , intent(OUT) :: L2_norm
5024 real , intent(OUT) :: Linf_norm
5025
5026 type(fv_grid_type), target :: gridstruct
5027
5028 real :: vmean
5029 real :: vvar
5030 real :: vmin1
5031 real :: vmax1
5032 real :: pdiffmn
5033 real :: pdiffmx
5034
5035 real :: varSUM, varSUM2, varMAX
5036 real :: gsum
5037 real :: vminT, vmaxT, vmeanT, vvarT
5038 integer :: i0, j0, n0
5039
5040 real, dimension(:,:,:), pointer :: grid, agrid
5041 real, dimension(:,:), pointer :: area
5042
5043 grid => gridstruct%grid
5044 agrid=> gridstruct%agrid
5045
5046 area => gridstruct%area
5047
5048 varSUM = 0.
5049 varSUM2 = 0.
5050 varMAX = 0.
5051 L1_norm = 0.
5052 L2_norm = 0.
5053 Linf_norm = 0.
5054 vmean = 0.
5055 vvar = 0.
5056 vmax = 0.
5057 vmin = 0.
5058 pdiffmn= 0.
5059 pdiffmx= 0.
5060 vmeanT = 0.
5061 vvarT = 0.
5062 vmaxT = 0.
5063 vminT = 0.
5064
5065 vmean = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5066 vmeanT = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5067 vmean = vmean / (4.0*pi)
5068 vmeanT = vmeanT / (4.0*pi)
5069
5070 call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin , vmax , i0, j0, n0)
5071 call pmxn(varT, npx, npy, nregions, tile, gridstruct, vminT, vmaxT, i0, j0, n0)
5072 call pmxn(var-varT, npx, npy, nregions, tile, gridstruct, pdiffmn, pdiffmx, i0, j0, n0)
5073
5074 vmax = (vmax - vmaxT) / (vmaxT-vminT)
5075 vmin = (vmin - vminT) / (vmaxT-vminT)
5076
5077 varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5078 varSUM2 = globalsum(varT(is:ie,js:je)**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5079 L1_norm = globalsum(ABS(var(is:ie,js:je)-varT(is:ie,js:je)), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5080 L2_norm = globalsum((var(is:ie,js:je)-varT(is:ie,js:je))**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5081 L1_norm = L1_norm/varSUM
5082 L2_norm = SQRT(L2_norm)/SQRT(varSUM2)
5083
5084 call pmxn(ABS(varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5085 varMAX = vmax
5086 call pmxn(ABS(var-varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5087 Linf_norm = vmax/varMAX
5088
5089 end subroutine get_scalar_stats
5090 !
5091 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5092 !-------------------------------------------------------------------------------
5093
5094 !-------------------------------------------------------------------------------
5095 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5096 !
5097 ! get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
5098 ! in Williamson, 1994 (p.16)
5099 ! for any var
5100
5101 subroutine get_vector_stats(varU, varUT, varV, varVT, &
5102 npx, npy, ndims, nregions, &
5103 vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
5104 integer, intent(IN) :: npx, npy
5105 integer, intent(IN) :: ndims
5106 integer, intent(IN) :: nregions, tile
5107 real , intent(IN) :: varU(isd:ied,jsd:jed)
5108 real , intent(IN) :: varUT(isd:ied,jsd:jed)
5109 real , intent(IN) :: varV(isd:ied,jsd:jed)
5110 real , intent(IN) :: varVT(isd:ied,jsd:jed)
5111 real , intent(OUT) :: vmin
5112 real , intent(OUT) :: vmax
5113 real , intent(OUT) :: L1_norm
5114 real , intent(OUT) :: L2_norm
5115 real , intent(OUT) :: Linf_norm
5116
5117 real :: var(isd:ied,jsd:jed)
5118 real :: varT(isd:ied,jsd:jed)
5119 real :: vmean
5120 real :: vvar
5121 real :: vmin1
5122 real :: vmax1
5123 real :: pdiffmn
5124 real :: pdiffmx
5125
5126 real :: varSUM, varSUM2, varMAX
5127 real :: gsum
5128 real :: vminT, vmaxT, vmeanT, vvarT
5129 integer :: i,j,n
5130 integer :: i0, j0, n0
5131
5132 type(fv_grid_type), target :: gridstruct
5133
5134 real, dimension(:,:,:), pointer :: grid, agrid
5135 real, dimension(:,:), pointer :: area
5136
5137 grid => gridstruct%grid
5138 agrid=> gridstruct%agrid
5139
5140 area => gridstruct%area
5141
5142 varSUM = 0.
5143 varSUM2 = 0.
5144 varMAX = 0.
5145 L1_norm = 0.
5146 L2_norm = 0.
5147 Linf_norm = 0.
5148 vmean = 0.
5149 vvar = 0.
5150 vmax = 0.
5151 vmin = 0.
5152 pdiffmn= 0.
5153 pdiffmx= 0.
5154 vmeanT = 0.
5155 vvarT = 0.
5156 vmaxT = 0.
5157 vminT = 0.
5158
5159 do j=js,je
5160 do i=is,ie
5161 var(i,j) = SQRT( (varU(i,j)-varUT(i,j))**2. + &
5162 (varV(i,j)-varVT(i,j))**2. )
5163 varT(i,j) = SQRT( varUT(i,j)*varUT(i,j) + &
5164 varVT(i,j)*varVT(i,j) )
5165 enddo
5166 enddo
5167 varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5168 L1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5169 L1_norm = L1_norm/varSUM
5170
5171 call pmxn(varT, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5172 varMAX = vmax
5173 call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5174 Linf_norm = vmax/varMAX
5175
5176 do j=js,je
5177 do i=is,ie
5178 var(i,j) = ( (varU(i,j)-varUT(i,j))**2. + &
5179 (varV(i,j)-varVT(i,j))**2. )
5180 varT(i,j) = ( varUT(i,j)*varUT(i,j) + &
5181 varVT(i,j)*varVT(i,j) )
5182 enddo
5183 enddo
5184 varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5185 L2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5186 L2_norm = SQRT(L2_norm)/SQRT(varSUM)
5187
5188 end subroutine get_vector_stats
5189 !
5190 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5191 !-------------------------------------------------------------------------------
5192
5193 !-------------------------------------------------------------------------------
5194 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5195 !
5196 ! check_courant_numbers ::
5197 !
5198 subroutine check_courant_numbers(uc,vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint)
5199
5200 real, intent(IN) :: ndt
5201 integer, intent(IN) :: n_split
5202 integer, intent(IN) :: npx, npy, npz, tile
5203 logical, OPTIONAL, intent(IN) :: noPrint
5204 real , intent(IN) :: uc(isd:ied+1,jsd:jed ,npz)
5205 real , intent(IN) :: vc(isd:ied ,jsd:jed+1,npz)
5206
5207 real :: ideal_c=0.06
5208 real :: tolerance= 1.e-3
5209 real :: dt_inc, dt_orig
5210 real :: meanCy, minCy, maxCy, meanCx, minCx, maxCx
5211
5212 real :: counter
5213 logical :: ideal
5214
5215 integer :: i,j,k
5216 real :: dt
5217
5218 type(fv_grid_type), intent(IN), target :: gridstruct
5219 real, dimension(:,:), pointer :: dxc, dyc
5220
5221 dxc => gridstruct%dxc
5222 dyc => gridstruct%dyc
5223
5224 dt = ndt/real(n_split)
5225
5226 300 format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
5227
5228 dt_orig = dt
5229 dt_inc = 1
5230 ideal = .false.
5231
5232 do while(.not. ideal)
5233
5234 counter = 0
5235 minCy = missing
5236 maxCy = -1.*missing
5237 minCx = missing
5238 maxCx = -1.*missing
5239 meanCx = 0
5240 meanCy = 0
5241 do k=1,npz
5242 do j=js,je
5243 do i=is,ie+1
5244 minCx = MIN(minCx, ABS( (dt/dxc(i,j))*uc(i,j,k) ))
5245 maxCx = MAX(maxCx, ABS( (dt/dxc(i,j))*uc(i,j,k) ))
5246 meanCx = meanCx + ABS( (dt/dxc(i,j))*uc(i,j,k) )
5247
5248 if (ABS( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then
5249 counter = counter+1
5250 write(*,300) i,j,k,tile, ABS( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter
5251 call exit(1)
5252 endif
5253
5254 enddo
5255 enddo
5256 do j=js,je+1
5257 do i=is,ie
5258 minCy = MIN(minCy, ABS( (dt/dyc(i,j))*vc(i,j,k) ))
5259 maxCy = MAX(maxCy, ABS( (dt/dyc(i,j))*vc(i,j,k) ))
5260 meanCy = meanCy + ABS( (dt/dyc(i,j))*vc(i,j,k) )
5261
5262 if (ABS( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then
5263 counter = counter+1
5264 write(*,300) i,j,k,tile, ABS( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter
5265 call exit(1)
5266 endif
5267
5268 enddo
5269 enddo
5270 enddo
5271
5272 call mp_reduce_max(maxCx)
5273 call mp_reduce_max(maxCy)
5274 minCx = -minCx
5275 minCy = -minCy
5276 call mp_reduce_max(minCx)
5277 call mp_reduce_max(minCy)
5278 minCx = -minCx
5279 minCy = -minCy
5280 call mp_reduce_sum(meanCx)
5281 call mp_reduce_sum(meanCy)
5282 meanCx = meanCx/(6.0*DBLE(npx)*DBLE(npy-1))
5283 meanCy = meanCy/(6.0*DBLE(npx-1)*DBLE(npy))
5284
5285 !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then
5286 ideal = .true.
5287 !elseif (maxCy-ideal_c > 0) then
5288 ! dt = dt - dt_inc
5289 !else
5290 ! dt = dt + dt_inc
5291 !endif
5292
5293 enddo
5294
5295 if ( (.not. present(noPrint)) .and. (is_master()) ) then
5296 print*, ''
5297 print*, '--------------------------------------------'
5298 print*, 'Y-dir Courant number MIN : ', minCy
5299 print*, 'Y-dir Courant number MAX : ', maxCy
5300 print*, ''
5301 print*, 'X-dir Courant number MIN : ', minCx
5302 print*, 'X-dir Courant number MAX : ', maxCx
5303 print*, ''
5304 print*, 'X-dir Courant number MEAN : ', meanCx
5305 print*, 'Y-dir Courant number MEAN : ', meanCy
5306 print*, ''
5307 print*, 'NDT: ', ndt
5308 print*, 'n_split: ', n_split
5309 print*, 'DT: ', dt
5310 print*, ''
5311 print*, '--------------------------------------------'
5312 print*, ''
5313 endif
5314
5315 end subroutine check_courant_numbers
5316 !
5317 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5318 !-------------------------------------------------------------------------------
5319
5320 !-------------------------------------------------------------------------------
5321 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5322 !
5323 ! pmxn :: find max and min of field p
5324 !
5325 subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
5326 integer, intent(IN) :: npx
5327 integer, intent(IN) :: npy
5328 integer, intent(IN) :: nregions, tile
5329 real , intent(IN) :: p(isd:ied,jsd:jed)
5330 type(fv_grid_type), intent(IN), target :: gridstruct
5331 real , intent(OUT) :: pmin
5332 real , intent(OUT) :: pmax
5333 integer, intent(OUT) :: i0
5334 integer, intent(OUT) :: j0
5335 integer, intent(OUT) :: n0
5336
5337 real :: temp
5338 integer :: i,j,n
5339
5340
5341 real, pointer, dimension(:,:,:) :: agrid, grid
5342 real, pointer, dimension(:,:) :: area, rarea, fC, f0
5343 real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
5344 real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
5345 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5346
5347 logical, pointer :: cubed_sphere, latlon
5348
5349 logical, pointer :: have_south_pole, have_north_pole
5350
5351 integer, pointer :: ntiles_g
5352 real, pointer :: acapN, acapS, globalarea
5353
5354 grid => gridstruct%grid
5355 agrid=> gridstruct%agrid
5356
5357 area => gridstruct%area
5358 rarea => gridstruct%rarea
5359
5360 fC => gridstruct%fC
5361 f0 => gridstruct%f0
5362
5363 ee1 => gridstruct%ee1
5364 ee2 => gridstruct%ee2
5365 ew => gridstruct%ew
5366 es => gridstruct%es
5367 en1 => gridstruct%en1
5368 en2 => gridstruct%en2
5369
5370 dx => gridstruct%dx
5371 dy => gridstruct%dy
5372 dxa => gridstruct%dxa
5373 dya => gridstruct%dya
5374 rdxa => gridstruct%rdxa
5375 rdya => gridstruct%rdya
5376 dxc => gridstruct%dxc
5377 dyc => gridstruct%dyc
5378
5379 cubed_sphere => gridstruct%cubed_sphere
5380 latlon => gridstruct%latlon
5381
5382 have_south_pole => gridstruct%have_south_pole
5383 have_north_pole => gridstruct%have_north_pole
5384
5385 ntiles_g => gridstruct%ntiles_g
5386 acapN => gridstruct%acapN
5387 acapS => gridstruct%acapS
5388 globalarea => gridstruct%globalarea
5389
5390 pmax = -1.e25
5391 pmin = 1.e25
5392 i0 = -999
5393 j0 = -999
5394 n0 = tile
5395
5396 do j=js,je
5397 do i=is,ie
5398 temp = p(i,j)
5399 if (temp > pmax) then
5400 pmax = temp
5401 i0 = i
5402 j0 = j
5403 elseif (temp < pmin) then
5404 pmin = temp
5405 endif
5406 enddo
5407 enddo
5408
5409 temp = pmax
5410 call mp_reduce_max(temp)
5411 if (temp /= pmax) then
5412 i0 = -999
5413 j0 = -999
5414 n0 = -999
5415 endif
5416 pmax = temp
5417 call mp_reduce_max(i0)
5418 call mp_reduce_max(j0)
5419 call mp_reduce_max(n0)
5420
5421 pmin = -pmin
5422 call mp_reduce_max(pmin)
5423 pmin = -pmin
5424
5425 end subroutine pmxn
5426 !
5427 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5428 !-------------------------------------------------------------------------------
5429
5430 !! These routines are no longer used
5431 #ifdef NCDF_OUTPUT
5432
5433 !-------------------------------------------------------------------------------
5434 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5435 !
5436 ! output_ncdf :: write out NETCDF fields
5437 !
5438 subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5439 omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, &
5440 npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, &
5441 phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids, &
5442 lats_id, lons_id, gridstruct, flagstruct)
5443 real, intent(IN) :: dt
5444 integer, intent(IN) :: nt, maxnt
5445 integer, intent(INOUT) :: nout
5446
5447 real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5448 real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5449 real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5450 real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5451 real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5452
5453 real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5454 real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5455
5456 real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5457 real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5458 real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5459 real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5460 real , intent(INOUT) :: omga(isd:ied ,jsd:jed ,npz)
5461
5462 integer, intent(IN) :: npx, npy, npz
5463 integer, intent(IN) :: ng, ncnst
5464 integer, intent(IN) :: ndims
5465 integer, intent(IN) :: nregions
5466 integer, intent(IN) :: ncid
5467 integer, intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id
5468 integer, intent(IN) :: ntiles_id, nt_id
5469 integer, intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id
5470 integer, intent(IN) :: om_id ! omega (dp/dt)
5471 integer, intent(IN) :: tracers_ids(ncnst-1)
5472 integer, intent(IN) :: lats_id, lons_id
5473
5474 type(fv_grid_type), target :: gridstruct
5475 type(fv_flags_type), intent(IN) :: flagstruct
5476
5477 real, allocatable :: tmp(:,:,:)
5478 real, allocatable :: tmpA(:,:,:)
5479 #if defined(SW_DYNAMICS)
5480 real, allocatable :: ut(:,:,:)
5481 real, allocatable :: vt(:,:,:)
5482 #else
5483 real, allocatable :: ut(:,:,:,:)
5484 real, allocatable :: vt(:,:,:,:)
5485 real, allocatable :: tmpA_3d(:,:,:,:)
5486 #endif
5487 real, allocatable :: vort(:,:)
5488
5489 real :: p1(2) ! Temporary Point
5490 real :: p2(2) ! Temporary Point
5491 real :: p3(2) ! Temporary Point
5492 real :: p4(2) ! Temporary Point
5493 real :: pa(2) ! Temporary Point
5494 real :: utmp, vtmp, r, r0, dist, heading
5495 integer :: i,j,k,n,iq,nreg
5496
5497 real :: Vtx, p, w_p
5498 real :: x1,y1,z1,x2,y2,z2,ang
5499
5500 real, pointer, dimension(:,:,:) :: agrid, grid
5501 real, pointer, dimension(:,:) :: area, rarea
5502 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5503
5504 grid => gridstruct%grid
5505 agrid => gridstruct%agrid
5506
5507 area => gridstruct%area
5508 rarea => gridstruct%rarea
5509
5510 dx => gridstruct%dx
5511 dy => gridstruct%dy
5512 dxa => gridstruct%dxa
5513 dya => gridstruct%dya
5514 rdxa => gridstruct%rdxa
5515 rdya => gridstruct%rdya
5516 dxc => gridstruct%dxc
5517 dyc => gridstruct%dyc
5518
5519 allocate( tmp(npx ,npy ,nregions) )
5520 allocate( tmpA(npx-1,npy-1,nregions) )
5521 #if defined(SW_DYNAMICS)
5522 allocate( ut(npx-1,npy-1,nregions) )
5523 allocate( vt(npx-1,npy-1,nregions) )
5524 #else
5525 allocate( ut(npx-1,npy-1,npz,nregions) )
5526 allocate( vt(npx-1,npy-1,npz,nregions) )
5527 allocate( tmpA_3d(npx-1,npy-1,npz,nregions) )
5528 #endif
5529 allocate( vort(isd:ied,jsd:jed) )
5530
5531 nout = nout + 1
5532
5533 if (nt==0) then
5534 tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2)
5535 call wrtvar_ncdf(ncid, lats_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3)
5536 tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1)
5537 call wrtvar_ncdf(ncid, lons_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3)
5538 endif
5539
5540 #if defined(SW_DYNAMICS)
5541 if (test_case > 1) then
5542 tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav
5543
5544 if ((nt==0) .and. (test_case==2)) then
5545 Ubar = (2.0*pi*radius)/(12.0*86400.0)
5546 gh0 = 2.94e4
5547 phis = 0.0
5548 do j=js,je+1
5549 do i=is,ie+1
5550 tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
5551 ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5552 sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav
5553 enddo
5554 enddo
5555 endif
5556
5557 else
5558
5559 if (test_case==1) then
5560 ! Get Current Height Field "Truth"
5561 p1(1) = pi/2. + pi_shift
5562 p1(2) = 0.
5563 p2(1) = 3.*pi/2. + pi_shift
5564 p2(2) = 0.
5565 r0 = radius/3. !RADIUS /3.
5566 dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
5567 heading = 5.0*pi/2.0 - alpha
5568 call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5569 do j=jsd,jed
5570 do i=isd,ied
5571 p2(1) = agrid(i,j,1)
5572 p2(2) = agrid(i,j,2)
5573 r = great_circle_dist( p3, p2, radius )
5574 if (r < r0) then
5575 phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
5576 else
5577 phi0(i,j,1) = phis(i,j)
5578 endif
5579 enddo
5580 enddo
5581 elseif (test_case == 0) then
5582 phi0 = 0.0
5583 do j=jsd,jed
5584 do i=isd,ied
5585 x1 = agrid(i,j,1)
5586 y1 = agrid(i,j,2)
5587 z1 = radius
5588 p = p0_c0 * cos(y1)
5589 Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5590 w_p = 0.0
5591 if (p /= 0.0) w_p = Vtx/p
5592 phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5593 enddo
5594 enddo
5595 endif
5596
5597 tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5598 call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5599 tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5600 endif
5601 call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5602
5603 if (test_case == 9) then
5604 ! Calc Vorticity
5605 do j=jsd,jed
5606 do i=isd,ied
5607 vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
5608 (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5609 vort(i,j) = Grav*vort(i,j)/delp(i,j,1)
5610 enddo
5611 enddo
5612 tmpA(is:ie,js:je,tile) = vort(is:ie,js:je)
5613 call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5614 endif
5615
5616 call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, 1, 1, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord, bd)
5617 do j=js,je
5618 do i=is,ie
5619 ut(i,j,tile) = ua(i,j,1)
5620 vt(i,j,tile) = va(i,j,1)
5621 enddo
5622 enddo
5623
5624 call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:nregions), 3)
5625 call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:nregions), 3)
5626
5627 if ((test_case >= 2) .and. (nt==0) ) then
5628 tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
5629 call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5630 endif
5631 #else
5632
5633 ! Write Moisture Data
5634 tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1)
5635 call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5636
5637 ! Write Tracer Data
5638 do iq=2,ncnst
5639 tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq)
5640 call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5641 enddo
5642
5643 ! Write Surface height data
5644 tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
5645 call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3)
5646
5647 ! Write Pressure Data
5648 tmpA(is:ie,js:je,tile) = ps(is:ie,js:je)
5649 call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3)
5650 do k=1,npz
5651 tmpA_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/Grav
5652 enddo
5653 call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5654
5655 ! Write PT Data
5656 do k=1,npz
5657 tmpA_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k)
5658 enddo
5659 call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5660
5661 ! Write U,V Data
5662 call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, npz, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord)
5663 do k=1,npz
5664 do j=js,je
5665 do i=is,ie
5666 ut(i,j,k,tile) = ua(i,j,k)
5667 vt(i,j,k,tile) = va(i,j,k)
5668 enddo
5669 enddo
5670 enddo
5671 call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:npz,1:nregions), 4)
5672 call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:npz,1:nregions), 4)
5673
5674
5675 ! Calc Vorticity
5676 do k=1,npz
5677 do j=js,je
5678 do i=is,ie
5679 tmpA_3d(i,j,k,tile) = rarea(i,j) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - &
5680 (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
5681 enddo
5682 enddo
5683 enddo
5684 call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5685 !
5686 ! Output omega (dp/dt):
5687 do k=1,npz
5688 do j=js,je
5689 do i=is,ie
5690 tmpA_3d(i,j,k,tile) = omga(i,j,k)
5691 enddo
5692 enddo
5693 enddo
5694 call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5695
5696 #endif
5697
5698 deallocate( tmp )
5699 deallocate( tmpA )
5700 #if defined(SW_DYNAMICS)
5701 deallocate( ut )
5702 deallocate( vt )
5703 #else
5704 deallocate( ut )
5705 deallocate( vt )
5706 deallocate( tmpA_3d )
5707 #endif
5708 deallocate( vort )
5709
5710 nullify(grid)
5711 nullify(agrid)
5712
5713 nullify(area)
5714
5715 nullify(dx)
5716 nullify(dy)
5717 nullify(dxa)
5718 nullify(dya)
5719 nullify(rdxa)
5720 nullify(rdya)
5721 nullify(dxc)
5722 nullify(dyc)
5723
5724 end subroutine output_ncdf
5725
5726 !
5727 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5728 !-------------------------------------------------------------------------------
5729
5730 !-------------------------------------------------------------------------------
5731 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5732 !
5733 ! output :: write out fields
5734 !
5735 subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5736 npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, &
5737 pt_lun, pv_lun, uv_lun, gridstruct)
5738
5739 real, intent(IN) :: dt
5740 integer, intent(IN) :: nt, maxnt
5741 integer, intent(INOUT) :: nout
5742
5743 real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5744 real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5745 real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5746 real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5747 real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5748
5749 real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5750 real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5751
5752 real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5753 real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5754 real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5755 real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5756
5757 integer, intent(IN) :: npx, npy, npz
5758 integer, intent(IN) :: ng, ncnst
5759 integer, intent(IN) :: ndims
5760 integer, intent(IN) :: nregions
5761 integer, intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun
5762
5763 type(fv_grid_type), target :: gridstruct
5764
5765 real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
5766 real :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions)
5767 real :: p1(2) ! Temporary Point
5768 real :: p2(2) ! Temporary Point
5769 real :: p3(2) ! Temporary Point
5770 real :: p4(2) ! Temporary Point
5771 real :: pa(2) ! Temporary Point
5772 real :: ut(1:npx,1:npy,1:nregions)
5773 real :: vt(1:npx,1:npy,1:nregions)
5774 real :: utmp, vtmp, r, r0, dist, heading
5775 integer :: i,j,k,n,nreg
5776 real :: vort(isd:ied,jsd:jed)
5777
5778 real :: Vtx, p, w_p
5779 real :: x1,y1,z1,x2,y2,z2,ang
5780
5781 real, pointer, dimension(:,:,:) :: agrid, grid
5782 real, pointer, dimension(:,:) :: area, rarea
5783 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5784
5785 grid => gridstruct%grid
5786 agrid => gridstruct%agrid
5787
5788 area => gridstruct%area
5789
5790 dx => gridstruct%dx
5791 dy => gridstruct%dy
5792 dxa => gridstruct%dxa
5793 dya => gridstruct%dya
5794 rdxa => gridstruct%rdxa
5795 rdya => gridstruct%rdya
5796 dxc => gridstruct%dxc
5797 dyc => gridstruct%dyc
5798
5799 cubed_sphere => gridstruct%cubed_sphere
5800
5801 nout = nout + 1
5802
5803 #if defined(SW_DYNAMICS)
5804 if (test_case > 1) then
5805 call atob_s(delp(:,:,1)/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5806 tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav
5807
5808 if ((nt==0) .and. (test_case==2)) then
5809 Ubar = (2.0*pi*radius)/(12.0*86400.0)
5810 gh0 = 2.94e4
5811 phis = 0.0
5812 do j=js,je+1
5813 do i=is,ie+1
5814 tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
5815 ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5816 sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav
5817 enddo
5818 enddo
5819 endif
5820
5821 else
5822
5823 if (test_case==1) then
5824 ! Get Current Height Field "Truth"
5825 p1(1) = pi/2. + pi_shift
5826 p1(2) = 0.
5827 p2(1) = 3.*pi/2. + pi_shift
5828 p2(2) = 0.
5829 r0 = radius/3. !RADIUS /3.
5830 dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
5831 heading = 5.0*pi/2.0 - alpha
5832 call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5833 do j=jsd,jed
5834 do i=isd,ied
5835 p2(1) = agrid(i,j,1)
5836 p2(2) = agrid(i,j,2)
5837 r = great_circle_dist( p3, p2, radius )
5838 if (r < r0) then
5839 phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
5840 else
5841 phi0(i,j,1) = phis(i,j)
5842 endif
5843 enddo
5844 enddo
5845 elseif (test_case == 0) then
5846 phi0 = 0.0
5847 do j=jsd,jed
5848 do i=isd,ied
5849 x1 = agrid(i,j,1)
5850 y1 = agrid(i,j,2)
5851 z1 = radius
5852 p = p0_c0 * cos(y1)
5853 Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5854 w_p = 0.0
5855 if (p /= 0.0) w_p = Vtx/p
5856 phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5857 enddo
5858 enddo
5859 endif
5860
5861 call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5862 tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5863 call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5864 call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5865 tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5866 endif
5867 ! call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5868 call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5869
5870 if (test_case == 9) then
5871 ! Calc Vorticity
5872 do j=jsd,jed
5873 do i=isd,ied
5874 vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
5875 (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5876 vort(i,j) = Grav*vort(i,j)/delp(i,j,1)
5877 enddo
5878 enddo
5879 call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5880 call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5881 endif
5882
5883 call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
5884 ! Rotate winds to standard Lat-Lon orientation
5885 if (cubed_sphere) then
5886 do j=js,je
5887 do i=is,ie
5888 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
5889 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
5890 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
5891 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
5892 utmp = ua(i,j,1)
5893 vtmp = va(i,j,1)
5894 if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
5895 ut(i,j,tile) = utmp
5896 vt(i,j,tile) = vtmp
5897 enddo
5898 enddo
5899 endif
5900
5901 call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions))
5902 call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions))
5903
5904 if ((test_case >= 2) .and. (nt==0) ) then
5905 call atob_s(phis/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5906 ! call wrt2d(phis_lun, nout , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5907 tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
5908 call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5909 endif
5910 #else
5911
5912 ! Write Surface height data
5913 if (nt==0) then
5914 tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
5915 call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5916 endif
5917
5918 ! Write Pressure Data
5919
5920 !if (tile==2) then
5921 ! do i=is,ie
5922 ! print*, i, ps(i,35)
5923 ! enddo
5924 !endif
5925 tmpA(is:ie,js:je,tile) = ps(is:ie,js:je)
5926 call wrt2d(phi_lun, (nout-1)*(npz+1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5927 do k=1,npz
5928 tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,k)/Grav
5929 call wrt2d(phi_lun, (nout-1)*(npz+1) + 1 + k, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5930 enddo
5931
5932 ! Write PT Data
5933 do k=1,npz
5934 tmpA(is:ie,js:je,tile) = pt(is:ie,js:je,k)
5935 call wrt2d(pt_lun, (nout-1)*npz + (k-1) + 1, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5936 enddo
5937
5938 ! Write U,V Data
5939 do k=1,npz
5940 call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
5941 ! Rotate winds to standard Lat-Lon orientation
5942 if (cubed_sphere) then
5943 do j=js,je
5944 do i=is,ie
5945 call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
5946 call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
5947 call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
5948 call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
5949 utmp = ua(i,j,k)
5950 vtmp = va(i,j,k)
5951 if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
5952 ut(i,j,tile) = utmp
5953 vt(i,j,tile) = vtmp
5954 enddo
5955 enddo
5956 endif
5957 call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions))
5958 call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions))
5959 enddo
5960 #endif
5961
5962 nullify(grid)
5963 nullify(agrid)
5964
5965 nullify(area)
5966
5967 nullify(dx)
5968 nullify(dy)
5969 nullify(dxa)
5970 nullify(dya)
5971 nullify(rdxa)
5972 nullify(rdya)
5973 nullify(dxc)
5974 nullify(dyc)
5975
5976 nullify(cubed_sphere)
5977
5978 end subroutine output
5979 !
5980 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5981 !-------------------------------------------------------------------------------
5982
5983 !-------------------------------------------------------------------------------
5984 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5985 ! wrt2d_ncdf :: write out a 2d field
5986 !
5987 subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims)
5988 #include <netcdf.inc>
5989 integer, intent(IN) :: ncid, varid
5990 integer, intent(IN) :: nrec
5991 integer, intent(IN) :: i1,i2,j1,j2
5992 integer, intent(IN) :: npx
5993 integer, intent(IN) :: npy
5994 integer, intent(IN) :: npz
5995 integer, intent(IN) :: ntiles
5996 real , intent(IN) :: p(npx-1,npy-1,npz,ntiles)
5997 integer, intent(IN) :: ndims
5998
5999 integer :: error
6000 real(kind=4), allocatable :: p_R4(:,:,:,:)
6001 integer :: i,j,k,n
6002 integer :: istart(ndims+1), icount(ndims+1)
6003
6004 allocate( p_R4(npx-1,npy-1,npz,ntiles) )
6005
6006 p_R4(:,:,:,:) = missing
6007 p_R4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile)
6008 call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles)
6009
6010 istart(:) = 1
6011 istart(ndims+1) = nrec
6012 icount(1) = npx-1
6013 icount(2) = npy-1
6014 icount(3) = npz
6015 if (ndims == 3) icount(3) = ntiles
6016 if (ndims == 4) icount(4) = ntiles
6017 icount(ndims+1) = 1
6018
6019 if (is_master()) then
6020 error = NF_PUT_VARA_REAL(ncid, varid, istart, icount, p_R4)
6021 endif ! masterproc
6022
6023 deallocate( p_R4 )
6024
6025 end subroutine wrtvar_ncdf
6026 !
6027 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
6028 !-------------------------------------------------------------------------------
6029
6030 !-------------------------------------------------------------------------------
6031 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
6032 ! wrt2d :: write out a 2d field
6033 !
6034 subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p)
6035 integer, intent(IN) :: iout
6036 integer, intent(IN) :: nrec
6037 integer, intent(IN) :: i1,i2,j1,j2
6038 integer, intent(IN) :: npx
6039 integer, intent(IN) :: npy
6040 integer, intent(IN) :: nregions
6041 real , intent(IN) :: p(npx-1,npy-1,nregions)
6042
6043 real(kind=4) :: p_R4(npx-1,npy-1,nregions)
6044 integer :: i,j,n
6045
6046 do n=tile,tile
6047 do j=j1,j2
6048 do i=i1,i2
6049 p_R4(i,j,n) = p(i,j,n)
6050 enddo
6051 enddo
6052 enddo
6053
6054 call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, nregions)
6055
6056 if (is_master()) then
6057 write(iout,rec=nrec) p_R4(1:npx-1,1:npy-1,1:nregions)
6058 endif ! masterproc
6059
6060 end subroutine wrt2d
6061 !
6062 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
6063 !-------------------------------------------------------------------------------
6064 #endif
6065 !-------------------------------------------------------------------------------
6066 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
6067 ! init_double_periodic
6068 !
6069 subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
6070 gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, &
6071 mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd)
6072
6073
6074 type(fv_grid_bounds_type), intent(IN) :: bd
6075 real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6076 real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6077 real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
6078 real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6079 real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6080 real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
6081
6082 real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
6083
6084 real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
6085 real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
6086 real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
6087 real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
6088 real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
6089 real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6090 real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6091 real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6092 real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6093 real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:)
6094 real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
6095
6096 real , intent(inout) :: ak(npz+1)
6097 real , intent(inout) :: bk(npz+1)
6098
6099 integer, intent(IN) :: npx, npy, npz
6100 integer, intent(IN) :: ng, ncnst, nwat
6101 integer, intent(IN) :: ndims
6102 integer, intent(IN) :: nregions
6103
6104 real, intent(IN) :: dry_mass
6105 logical, intent(IN) :: mountain
6106 logical, intent(IN) :: moist_phys
6107 logical, intent(IN) :: hydrostatic, hybrid_z
6108 integer, intent(INOUT) :: ks
6109 integer, intent(INOUT), target :: tile_in
6110 real, intent(INOUT) :: ptop
6111
6112 type(domain2d), intent(IN), target :: domain_in
6113
6114 type(fv_grid_type), target :: gridstruct
6115 type(fv_flags_type), target :: flagstruct
6116
6117 real, dimension(bd%is:bd%ie):: pm, qs
6118 real, dimension(1:npz):: pk1, ts1, qs1
6119 real :: us0 = 30.
6120 real :: dist, r0, f0_const, prf, rgrav
6121 real :: ptmp, ze, zc, zm, utmp, vtmp
6122 real :: t00, p00, xmax, xc, xx, yy, pk0, pturb, ztop
6123 real :: ze1(npz+1)
6124 real:: dz1(npz)
6125 real:: zvir
6126 integer :: i, j, k, m, icenter, jcenter
6127
6128 real, pointer, dimension(:,:,:) :: agrid, grid
6129 real(kind=R_GRID), pointer, dimension(:,:) :: area
6130 real, pointer, dimension(:,:) :: rarea, fC, f0
6131 real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
6132 real, pointer, dimension(:,:,:,:) :: ew, es
6133 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
6134
6135 logical, pointer :: cubed_sphere, latlon
6136
6137 type(domain2d), pointer :: domain
6138 integer, pointer :: tile
6139
6140 logical, pointer :: have_south_pole, have_north_pole
6141
6142 integer, pointer :: ntiles_g
6143 real, pointer :: acapN, acapS, globalarea
6144
6145 real(kind=R_GRID), pointer :: dx_const, dy_const
6146
6147 integer :: is, ie, js, je
6148 integer :: isd, ied, jsd, jed
6149
6150 is = bd%is
6151 ie = bd%ie
6152 js = bd%js
6153 je = bd%je
6154 isd = bd%isd
6155 ied = bd%ied
6156 jsd = bd%jsd
6157 jed = bd%jed
6158
6159 agrid => gridstruct%agrid
6160 grid => gridstruct%grid
6161
6162 area => gridstruct%area_64
6163
6164 dx => gridstruct%dx
6165 dy => gridstruct%dy
6166 dxa => gridstruct%dxa
6167 dya => gridstruct%dya
6168 rdxa => gridstruct%rdxa
6169 rdya => gridstruct%rdya
6170 dxc => gridstruct%dxc
6171 dyc => gridstruct%dyc
6172
6173 fC => gridstruct%fC
6174 f0 => gridstruct%f0
6175
6176 !These are frequently used and so have pointers set up for them
6177 dx_const => flagstruct%dx_const
6178 dy_const => flagstruct%dy_const
6179
6180 domain => domain_in
6181 tile => tile_in
6182
6183 have_south_pole => gridstruct%have_south_pole
6184 have_north_pole => gridstruct%have_north_pole
6185
6186 ntiles_g => gridstruct%ntiles_g
6187 acapN => gridstruct%acapN
6188 acapS => gridstruct%acapS
6189 globalarea => gridstruct%globalarea
6190
6191 f0_const = 2.*omega*sin(flagstruct%deglat/180.*pi)
6192 f0(:,:) = f0_const
6193 fC(:,:) = f0_const
6194
6195 q = 0.
6196
6197 select case (test_case)
6198 case ( 1 )
6199
6200 phis(:,:)=0.
6201
6202 u (:,:,:)=10.
6203 v (:,:,:)=10.
6204 ua(:,:,:)=10.
6205 va(:,:,:)=10.
6206 uc(:,:,:)=10.
6207 vc(:,:,:)=10.
6208 pt(:,:,:)=1.
6209 delp(:,:,:)=0.
6210
6211 do j=js,je
6212 if (j>0 .and. j<5) then
6213 do i=is,ie
6214 if (i>0 .and. i<5) then
6215 delp(i,j,:)=1.
6216 endif
6217 enddo
6218 endif
6219 enddo
6220 call mpp_update_domains( delp, domain )
6221
6222 case ( 2 )
6223
6224 phis(:,:) = 0.
6225
6226 ! r0 = 5000.
6227 r0 = 5.*sqrt(dx_const**2 + dy_const**2)
6228 icenter = npx/2
6229 jcenter = npy/2
6230 do j=jsd,jed
6231 do i=isd,ied
6232 dist=(i-icenter)*dx_const*(i-icenter)*dx_const &
6233 +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6234 dist=min(r0,sqrt(dist))
6235 phis(i,j)=1500.*(1. - (dist/r0))
6236 enddo
6237 enddo
6238
6239 u (:,:,:)=0.
6240 v (:,:,:)=0.
6241 ua(:,:,:)=0.
6242 va(:,:,:)=0.
6243 uc(:,:,:)=0.
6244 vc(:,:,:)=0.
6245 pt(:,:,:)=1.
6246 delp(:,:,:)=1500.
6247
6248 case ( 14 )
6249 !---------------------------
6250 ! Doubly periodic Aqua-plane
6251 !---------------------------
6252 u(:,:,:) = 0.
6253 v(:,:,:) = 0.
6254 phis(:,:) = 0.
6255
6256 call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
6257 delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
6258
6259 ! *** Add Initial perturbation ***
6260 if (bubble_do) then
6261 r0 = 100.*sqrt(dx_const**2 + dy_const**2)
6262 icenter = npx/2
6263 jcenter = npy/2
6264
6265 do j=js,je
6266 do i=is,ie
6267 dist = (i-icenter)*dx_const*(i-icenter)*dx_const &
6268 +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6269 dist = min(r0, sqrt(dist))
6270 do k=1,npz
6271 prf = ak(k) + ps(i,j)*bk(k)
6272 if ( prf > 100.E2 ) then
6273 pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j)
6274 endif
6275 enddo
6276 enddo
6277 enddo
6278 endif
6279 if ( hydrostatic ) then
6280 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6281 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6282 moist_phys, .true., nwat , domain)
6283 else
6284 w(:,:,:) = 0.
6285 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6286 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6287 moist_phys, hydrostatic, nwat, domain, .true. )
6288 endif
6289
6290 q = 0.
6291 do k=1,npz
6292 do j=js,je
6293 do i=is,ie
6294 pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6295 enddo
6296 #ifdef MULTI_GASES
6297 call qsmith((ie-is+1)*(je-js+1), npz, &
6298 ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6299 #else
6300 call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6301 #endif
6302 do i=is,ie
6303 q(i,j,k,1) = max(2.E-6, 0.8*pm(i)/ps(i,j)*qs(i) )
6304 enddo
6305 enddo
6306 enddo
6307
6308 case ( 15 )
6309 !---------------------------
6310 ! Doubly periodic bubble
6311 !---------------------------
6312 t00 = 250.
6313
6314 u(:,:,:) = 0.
6315 v(:,:,:) = 0.
6316 pt(:,:,:) = t00
6317 q(:,:,:,:) = 1.E-6
6318
6319 if ( .not. hydrostatic ) w(:,:,:) = 0.
6320
6321 do j=jsd,jed
6322 do i=isd,ied
6323 phis(i,j) = 0.
6324 ps(i,j) = 1000.E2
6325 enddo
6326 enddo
6327
6328 do k=1,npz
6329 do j=jsd,jed
6330 do i=isd,ied
6331 delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6332 enddo
6333 enddo
6334 enddo
6335
6336
6337 do k=1,npz
6338 do j=jsd,jed
6339 do i=isd,ied
6340 ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6341 ! pt(i,j,k) = t00
6342 enddo
6343 enddo
6344 enddo
6345
6346 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6347 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6348 moist_phys, .false., nwat, domain)
6349
6350 ! *** Add Initial perturbation ***
6351 r0 = 5.*max(dx_const, dy_const)
6352 zc = 0.5e3 ! center of bubble from surface
6353 icenter = npx/2
6354 jcenter = npy/2
6355
6356 do j=js,je
6357 do i=is,ie
6358 ze = 0.
6359 do k=npz,1,-1
6360 zm = ze - 0.5*delz(i,j,k) ! layer center
6361 ze = ze - delz(i,j,k)
6362 dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + &
6363 (zm-zc)**2
6364 dist = sqrt(dist)
6365 if ( dist <= r0 ) then
6366 pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0)
6367 endif
6368 enddo
6369 enddo
6370 enddo
6371
6372 case ( 16 )
6373 !------------------------------------
6374 ! Non-hydrostatic 3D density current:
6375 !------------------------------------
6376 phis = 0.
6377 u = 0.
6378 v = 0.
6379 w = 0.
6380 t00 = 300.
6381 p00 = 1.E5
6382 pk0 = p00**kappa
6383 ! Set up vertical coordinare with constant del-z spacing:
6384 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
6385 ztop = 6.4E3
6386 ze1( 1) = ztop
6387 ze1(npz+1) = 0.
6388 do k=npz,2,-1
6389 ze1(k) = ze1(k+1) + ztop/real(npz)
6390 enddo
6391
6392 do j=js,je
6393 do i=is,ie
6394 ps(i,j) = p00
6395 pe(i,npz+1,j) = p00
6396 pk(i,j,npz+1) = pk0
6397 enddo
6398 enddo
6399
6400 do k=npz,1,-1
6401 do j=js,je
6402 do i=is,ie
6403 delz(i,j,k) = ze1(k+1) - ze1(k)
6404 pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
6405 pe(i,k,j) = pk(i,j,k)**(1./kappa)
6406 enddo
6407 enddo
6408 enddo
6409
6410 ptop = pe(is,1,js)
6411 if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
6412
6413 do k=1,npz+1
6414 do j=js,je
6415 do i=is,ie
6416 peln(i,k,j) = log(pe(i,k,j))
6417 ze0(i,j,k) = ze1(k)
6418 enddo
6419 enddo
6420 enddo
6421
6422 do k=1,npz
6423 do j=js,je
6424 do i=is,ie
6425 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6426 delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6427 pt(i,j,k) = t00/pk0 ! potential temp
6428 enddo
6429 enddo
6430 enddo
6431
6432 pturb = 15.
6433 xmax = 51.2E3
6434 xc = xmax / 2.
6435
6436 do k=1,npz
6437 zm = (0.5*(ze1(k)+ze1(k+1))-3.E3) / 2.E3
6438 do j=js,je
6439 do i=is,ie
6440 ! Impose perturbation in potential temperature: pturb
6441 xx = (dx_const * (0.5+real(i-1)) - xc) / 4.E3
6442 yy = (dy_const * (0.5+real(j-1)) - xc) / 4.E3
6443 dist = sqrt( xx**2 + yy**2 + zm**2 )
6444 if ( dist<=1. ) then
6445 pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
6446 endif
6447 ! Transform back to temperature:
6448 pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
6449 enddo
6450 enddo
6451 enddo
6452
6453 case ( 17 )
6454 !---------------------------
6455 ! Doubly periodic SuperCell, straight wind (v==0)
6456 !--------------------------
6457 zvir = rvgas/rdgas - 1.
6458 p00 = 1000.E2
6459 ps(:,:) = p00
6460 phis(:,:) = 0.
6461 do j=js,je
6462 do i=is,ie
6463 pk(i,j,1) = ptop**kappa
6464 pe(i,1,j) = ptop
6465 peln(i,1,j) = log(ptop)
6466 enddo
6467 enddo
6468
6469 do k=1,npz
6470 do j=js,je
6471 do i=is,ie
6472 delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6473 pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6474 peln(i,k+1,j) = log(pe(i,k+1,j))
6475 pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6476 enddo
6477 enddo
6478 enddo
6479
6480 i = is
6481 j = js
6482 do k=1,npz
6483 pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6484 enddo
6485
6486
6487 v(:,:,:) = 0.
6488 w(:,:,:) = 0.
6489 q(:,:,:,:) = 0.
6490
6491 do k=1,npz
6492 do j=js,je
6493 do i=is,ie
6494 pt(i,j,k) = ts1(k)
6495 q(i,j,k,1) = qs1(k)
6496 delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6497 enddo
6498 enddo
6499 enddo
6500
6501 ze1(npz+1) = 0.
6502 do k=npz,1,-1
6503 ze1(k) = ze1(k+1) - delz(is,js,k)
6504 enddo
6505
6506 do k=1,npz
6507 zm = 0.5*(ze1(k)+ze1(k+1))
6508 utmp = us0*tanh(zm/3.E3)
6509 do j=js,je+1
6510 do i=is,ie
6511 u(i,j,k) = utmp
6512 enddo
6513 enddo
6514 enddo
6515
6516 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6517 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6518 .true., hydrostatic, nwat, domain)
6519
6520 ! *** Add Initial perturbation ***
6521 pturb = 2.
6522 r0 = 10.e3
6523 zc = 1.4e3 ! center of bubble from surface
6524 icenter = (npx-1)/3 + 1
6525 jcenter = (npy-1)/2 + 1
6526 do k=1, npz
6527 zm = 0.5*(ze1(k)+ze1(k+1))
6528 ptmp = ( (zm-zc)/zc ) **2
6529 if ( ptmp < 1. ) then
6530 do j=js,je
6531 do i=is,ie
6532 dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
6533 if ( dist < 1. ) then
6534 pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
6535 endif
6536 enddo
6537 enddo
6538 endif
6539 enddo
6540
6541 case ( 18 )
6542 !---------------------------
6543 ! Doubly periodic SuperCell, quarter circle hodograph
6544 ! M. Toy, Apr 2013, MWR
6545 pturb = 2.5
6546 zvir = rvgas/rdgas - 1.
6547 p00 = 1000.E2
6548 ps(:,:) = p00
6549 phis(:,:) = 0.
6550 do j=js,je
6551 do i=is,ie
6552 pk(i,j,1) = ptop**kappa
6553 pe(i,1,j) = ptop
6554 peln(i,1,j) = log(ptop)
6555 enddo
6556 enddo
6557
6558 do k=1,npz
6559 do j=js,je
6560 do i=is,ie
6561 delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6562 pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6563 peln(i,k+1,j) = log(pe(i,k+1,j))
6564 pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6565 enddo
6566 enddo
6567 enddo
6568
6569 i = is
6570 j = js
6571 do k=1,npz
6572 pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6573 enddo
6574
6575
6576 w(:,:,:) = 0.
6577 q(:,:,:,:) = 0.
6578
6579 do k=1,npz
6580 do j=js,je
6581 do i=is,ie
6582 pt(i,j,k) = ts1(k)
6583 q(i,j,k,1) = qs1(k)
6584 delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6585 enddo
6586 enddo
6587 enddo
6588
6589 ze1(npz+1) = 0.
6590 do k=npz,1,-1
6591 ze1(k) = ze1(k+1) - delz(is,js,k)
6592 enddo
6593
6594 ! Quarter-circle hodograph (Harris approximation)
6595 us0 = 30.
6596 do k=1,npz
6597 zm = 0.5*(ze1(k)+ze1(k+1))
6598 if ( zm .le. 2.e3 ) then
6599 utmp = 8.*(1.-cos(pi*zm/4.e3))
6600 vtmp = 8.*sin(pi*zm/4.e3)
6601 elseif (zm .le. 6.e3 ) then
6602 utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
6603 vtmp = 8.
6604 else
6605 utmp = us0
6606 vtmp = 8.
6607 endif
6608 ! u-wind
6609 do j=js,je+1
6610 do i=is,ie
6611 u(i,j,k) = utmp - 8.
6612 enddo
6613 enddo
6614 ! v-wind
6615 do j=js,je
6616 do i=is,ie+1
6617 v(i,j,k) = vtmp - 4.
6618 enddo
6619 enddo
6620 enddo
6621
6622
6623 call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6624 pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6625 .true., hydrostatic, nwat, domain)
6626
6627 ! *** Add Initial perturbation ***
6628 if (bubble_do) then
6629 r0 = 10.e3
6630 zc = 1.4e3 ! center of bubble from surface
6631 icenter = (npx-1)/2 + 1
6632 jcenter = (npy-1)/2 + 1
6633 do k=1, npz
6634 zm = 0.5*(ze1(k)+ze1(k+1))
6635 ptmp = ( (zm-zc)/zc ) **2
6636 if ( ptmp < 1. ) then
6637 do j=js,je
6638 do i=is,ie
6639 dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
6640 if ( dist < 1. ) then
6641 pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
6642 endif
6643 enddo
6644 enddo
6645 endif
6646 enddo
6647 endif
6648
6649 case ( 101 )
6650
6651 ! IC for LES
6652 t00 = 250. ! constant temp
6653 p00 = 1.E5
6654 pk0 = p00**kappa
6655
6656 phis = 0.
6657 u = 0.
6658 v = 0.
6659 w = 0.
6660 pt(:,:,:) = t00
6661 q(:,:,:,1) = 0.
6662
6663 if (.not.hybrid_z) call mpp_error(FATAL, 'hybrid_z must be .TRUE.')
6664
6665 rgrav = 1./ grav
6666
6667 if ( npz/=101) then
6668 call mpp_error(FATAL, 'npz must be == 101 ')
6669 else
6670 call compute_dz_L101( npz, ztop, dz1 )
6671 endif
6672
6673 call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
6674 phis, ze0, delz)
6675
6676 do j=js,je
6677 do i=is,ie
6678 ps(i,j) = p00
6679 pe(i,npz+1,j) = p00
6680 pk(i,j,npz+1) = pk0
6681 peln(i,npz+1,j) = log(p00)
6682 enddo
6683 enddo
6684
6685 do k=npz,1,-1
6686 do j=js,je
6687 do i=is,ie
6688 peln(i,k,j) = peln(i,k+1,j) + grav*delz(i,j,k)/(rdgas*t00)
6689 pe(i,k,j) = exp(peln(i,k,j))
6690 pk(i,j,k) = pe(i,k,j)**kappa
6691 enddo
6692 enddo
6693 enddo
6694
6695
6696 ! Set up fake "sigma" coordinate
6697 call make_eta_level(npz, pe, area, ks, ak, bk, ptop, domain, bd)
6698
6699 if ( is_master() ) write(*,*) 'LES testcase: computed model top (mb)=', ptop/100.
6700
6701 do k=1,npz
6702 do j=js,je
6703 do i=is,ie
6704 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6705 delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6706 enddo
6707 enddo
6708 enddo
6709
6710 do k=1,npz
6711 do j=js,je
6712 do i=is,ie
6713 pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6714 enddo
6715 #ifdef MULTI_GASES
6716 call qsmith((ie-is+1)*(je-js+1), npz, &
6717 ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6718 #else
6719 call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6720 #endif
6721 do i=is,ie
6722 if ( pm(i) > 100.E2 ) then
6723 q(i,j,k,1) = 0.9*qs(i)
6724 else
6725 q(i,j,k,1) = 2.E-6
6726 endif
6727 enddo
6728 enddo
6729 enddo
6730
6731 ! *** Add perturbation ***
6732 r0 = 1.0e3 ! radius (m)
6733 zc = 1.0e3 ! center of bubble
6734 icenter = npx/2
6735 jcenter = npy/2
6736
6737 do k=1,npz
6738 do j=js,je
6739 do i=is,ie
6740 zm = 0.5*(ze0(i,j,k)+ze0(i,j,k+1))
6741 dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + (zm-zc)**2
6742 dist = sqrt(dist)
6743 if ( dist <= r0 ) then
6744 pt(i,j,k) = pt(i,j,k) + 2.0*(1.-dist/r0)
6745 endif
6746 enddo
6747 enddo
6748 enddo
6749
6750 end select
6751
6752 nullify(grid)
6753 nullify(agrid)
6754
6755 nullify(area)
6756
6757 nullify(fC)
6758 nullify(f0)
6759
6760 nullify(ee1)
6761 nullify(ee2)
6762 nullify(ew)
6763 nullify(es)
6764 nullify(en1)
6765 nullify(en2)
6766
6767 nullify(dx)
6768 nullify(dy)
6769 nullify(dxa)
6770 nullify(dya)
6771 nullify(rdxa)
6772 nullify(rdya)
6773 nullify(dxc)
6774 nullify(dyc)
6775
6776 nullify(dx_const)
6777 nullify(dy_const)
6778
6779 nullify(domain)
6780 nullify(tile)
6781
6782 nullify(have_south_pole)
6783 nullify(have_north_pole)
6784
6785 nullify(ntiles_g)
6786 nullify(acapN)
6787 nullify(acapS)
6788 nullify(globalarea)
6789
6790 end subroutine init_double_periodic
6791
6792 subroutine SuperK_Sounding(km, pe, p00, ze, pt, qz)
6793 integer, intent(in):: km
6794 real, intent(in):: p00
6795 real, intent(inout), dimension(km+1):: pe
6796 real, intent(in), dimension(km+1):: ze
6797 ! pt: potential temperature / pk0
6798 ! qz: specific humidity (mixing ratio)
6799 real, intent(out), dimension(km):: pt, qz
6800 ! Local:
6801 integer, parameter:: nx = 5
6802 real, parameter:: qst = 1.0e-6
6803 real, parameter:: qv0 = 1.4e-2
6804 real, parameter:: ztr = 12.E3
6805 real, parameter:: ttr = 213.
6806 real, parameter:: ptr = 343. !< Tropopause potential temp.
6807 real, parameter:: pt0 = 300. !< surface potential temperature
6808 real, dimension(km):: zs, rh, temp, dp, dp0
6809 real, dimension(km+1):: peln, pk
6810 real:: qs, zvir, fac_z, pk0, temp1, pm
6811 integer:: k, n, kk
6812
6813 zvir = rvgas/rdgas - 1.
6814 pk0 = p00**kappa
6815 if ( (is_master()) ) then
6816 write(*,*) 'Computing sounding for HIWPP super-cell test using p00=', p00
6817 endif
6818
6819 qz(:) = qst
6820 rh(:) = 0.25
6821
6822 do k=1, km
6823 zs(k) = 0.5*(ze(k)+ze(k+1))
6824 ! Potential temperature
6825 if ( zs(k) .gt. ztr ) then
6826 ! Stratosphere:
6827 pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr))
6828 else
6829 ! Troposphere:
6830 fac_z = (zs(k)/ztr)**1.25
6831 pt(k) = pt0 + (ptr-pt0)* fac_z
6832 rh(k) = 1. - 0.75 * fac_z
6833 ! First guess on q:
6834 qz(k) = qv0 - (qv0-qst)*fac_z
6835 endif
6836 if ( is_master() ) write(*,*) zs(k), pt(k), qz(k)
6837 ! Convert to FV's definition of potential temperature
6838 pt(k) = pt(k) / pk0
6839 enddo
6840
6841 #ifdef USE_MOIST_P00
6842 !--------------------------------------
6843 ! Iterate nx times with virtual effect:
6844 !--------------------------------------
6845 ! pt & height remain unchanged
6846 pk(km+1) = pk0
6847 pe(km+1) = p00 ! Dry
6848 peln(km+1) = log(p00)
6849
6850 do n=1, nx
6851 ! Derive pressure fields from hydrostatic balance:
6852 do k=km,1,-1
6853 pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
6854 peln(k) = log(pk(k)) / kappa
6855 pe(k) = exp(peln(k))
6856 enddo
6857 do k=1, km
6858 pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
6859 temp(k) = pt(k)*pm**kappa
6860 ! NCAR form:
6861 qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6862 qz(k) = min( qv0, rh(k)*qs )
6863 if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
6864 enddo
6865 enddo
6866 #else
6867 ! pt & height remain unchanged
6868 pk(km+1) = pk0
6869 pe(km+1) = p00 ! Dry
6870 peln(km+1) = log(p00)
6871
6872 ! Derive "dry" pressure fields from hydrostatic balance:
6873 do k=km,1,-1
6874 pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k))
6875 peln(k) = log(pk(k)) / kappa
6876 pe(k) = exp(peln(k))
6877 enddo
6878 do k=1, km
6879 dp0(k) = pe(k+1) - pe(k)
6880 pm = dp0(k)/(peln(k+1)-peln(k))
6881 temp(k) = pt(k)*pm**kappa
6882 ! NCAR form:
6883 qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6884 qz(k) = min( qv0, rh(k)*qs )
6885 enddo
6886
6887 do n=1, nx
6888
6889 do k=1, km
6890 dp(k) = dp0(k)*(1. + qz(k)) ! moist air
6891 pe(k+1) = pe(k) + dp(k)
6892 enddo
6893 ! dry pressure, pt & height remain unchanged
6894 pk(km+1) = pe(km+1)**kappa
6895 peln(km+1) = log(pe(km+1))
6896
6897 ! Derive pressure fields from hydrostatic balance:
6898 do k=km,1,-1
6899 pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
6900 peln(k) = log(pk(k)) / kappa
6901 pe(k) = exp(peln(k))
6902 enddo
6903 do k=1, km
6904 pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
6905 temp(k) = pt(k)*pm**kappa
6906 ! NCAR form:
6907 qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6908 qz(k) = min( qv0, rh(k)*qs )
6909 if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
6910 enddo
6911 enddo
6912 #endif
6913
6914 if ( is_master() ) then
6915 write(*,*) 'Super_K: computed ptop (mb)=', 0.01*pe(1), ' PS=', 0.01*pe(km+1)
6916 call prt_m1('1D Sounding T0', temp, 1, km, 1, 1, 0, 1, 1.)
6917 endif
6918
6919 end subroutine SuperK_Sounding
6920
6921 subroutine balanced_K(km, is, ie, js, je, ng, ps0, ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
6922 delz, zvir, ptop, ak, bk, agrid)
6923 integer, intent(in):: is, ie, js, je, ng, km
6924 real, intent(in), dimension(km ):: ts1, qs1, uz1, dudz
6925 real, intent(in), dimension(km+1):: ze1
6926 real, intent(in):: zvir, ps0
6927 real, intent(inout):: ptop
6928 real(kind=R_GRID), intent(in):: agrid(is-ng:ie+ng,js-ng:je+ng,2)
6929 real, intent(inout), dimension(km+1):: ak, bk
6930 real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delz
6931 real, intent(out), dimension(is:ie,js:je,km+1):: pk
6932 ! pt is FV's cp*thelta_v
6933 real, intent(inout), dimension(is-1:ie+1,km+1,js-1:je+1):: pe
6934 ! Local
6935 integer, parameter:: nt=5
6936 integer, parameter:: nlat=1001
6937 real, dimension(nlat,km):: pt2, pky, dzc
6938 real, dimension(nlat,km+1):: pk2, pe2, peln2, pte
6939 real, dimension(km+1):: pe1
6940 real:: lat(nlat), latc(nlat-1)
6941 real:: fac_y, dlat, dz0, pk0, tmp1, tmp2, tmp3, pint
6942 integer::i,j,k,n, jj, k1
6943 real:: p00=1.e5
6944
6945 pk0 = p00**kappa
6946 dz0 = ze1(km) - ze1(km+1)
6947 !!! dzc(:,:) =dz0
6948
6949 dlat = 0.5*pi/real(nlat-1)
6950 do j=1,nlat
6951 lat(j) = dlat*real(j-1)
6952 do k=1,km
6953 dzc(j,k) = ze1(k) - ze1(k+1)
6954 enddo
6955 enddo
6956 do j=1,nlat-1
6957 latc(j) = 0.5*(lat(j)+lat(j+1))
6958 enddo
6959
6960 ! Initialize pt2
6961 do k=1,km
6962 do j=1,nlat
6963 pt2(j,k) = ts1(k)
6964 enddo
6965 enddo
6966 if ( is_master() ) then
6967 tmp1 = pk0/cp_air
6968 call prt_m1('Super_K PT0', pt2, 1, nlat, 1, km, 0, 1, tmp1)
6969 endif
6970
6971 ! pt2 defined from Eq to NP
6972 ! Check NP
6973 do n=1, nt
6974 ! Compute edge values
6975 call ppme(pt2, pte, dzc, nlat, km)
6976 do k=1,km
6977 do j=2,nlat
6978 tmp1 = 0.5*(pte(j-1,k ) + pte(j,k ))
6979 tmp3 = 0.5*(pte(j-1,k+1) + pte(j,k+1))
6980 pt2(j,k) = pt2(j-1,k) + dlat/(2.*grav)*sin(2.*latc(j-1))*uz1(k)* &
6981 ( uz1(k)*(tmp1-tmp3)/dzc(j,k) - (pt2(j-1,k)+pt2(j,k))*dudz(k) )
6982 enddo
6983 enddo
6984 if ( is_master() ) then
6985 call prt_m1('Super_K PT', pt2, 1, nlat, 1, km, 0, 1, pk0/cp_air)
6986 endif
6987 enddo
6988 !
6989 ! Compute surface pressure using gradient-wind balance:
6990 !!! pk2(1,km+1) = pk0
6991 pk2(1,km+1) = ps0**kappa ! fixed at equator
6992 do j=2,nlat
6993 pk2(j,km+1) = pk2(j-1,km+1) - dlat*uz1(km)*uz1(km)*sin(2.*latc(j-1)) &
6994 / (pt2(j-1,km) + pt2(j,km))
6995 enddo
6996 ! Compute pressure using hydrostatic balance:
6997 do j=1,nlat
6998 do k=km,1,-1
6999 pk2(j,k) = pk2(j,k+1) - grav*dzc(j,k)/pt2(j,k)
7000 enddo
7001 enddo
7002
7003 do k=1,km+1
7004 do j=1,nlat
7005 peln2(j,k) = log(pk2(j,k)) / kappa
7006 pe2(j,k) = exp(peln2(j,k))
7007 enddo
7008 enddo
7009 ! Convert pt2 to temperature
7010 do k=1,km
7011 do j=1,nlat
7012 pky(j,k) = (pk2(j,k+1)-pk2(j,k))/(kappa*(peln2(j,k+1)-peln2(j,k)))
7013 pt2(j,k) = pt2(j,k)*pky(j,k)/(cp_air*(1.+zvir*qs1(k)))
7014 enddo
7015 enddo
7016
7017 do k=1,km+1
7018 pe1(k) = pe2(1,k)
7019 enddo
7020
7021 if ( is_master() ) then
7022 write(*,*) 'SuperK ptop at EQ=', 0.01*pe1(1), 'new ptop=', 0.01*ptop
7023 call prt_m1('Super_K pe', pe2, 1, nlat, 1, km+1, 0, 1, 0.01)
7024 call prt_m1('Super_K Temp', pt2, 1, nlat, 1, km, 0, 1, 1.)
7025 endif
7026
7027 ! Interpolate (pt2, pk2) from lat-dir to cubed-sphere
7028 do j=js, je
7029 do i=is, ie
7030 do jj=1,nlat-1
7031 if (abs(agrid(i,j,2))>=lat(jj) .and. abs(agrid(i,j,2))<=lat(jj+1) ) then
7032 ! found it !
7033 fac_y = (abs(agrid(i,j,2))-lat(jj)) / dlat
7034 do k=1,km
7035 pt(i, j,k) = pt2(jj, k) + fac_y*(pt2(jj+1, k)-pt2(jj,k))
7036 enddo
7037 do k=1,km+1
7038 pe(i,k,j) = pe2(jj,k) + fac_y*(pe2(jj+1,k)-pe2(jj,k))
7039 enddo
7040 ! k = km+1
7041 ! pk(i,j,k) = pk2(jj,k) + fac_y*(pk2(jj+1,k)-pk2(jj,k))
7042 goto 123
7043 endif
7044 enddo
7045 123 continue
7046 enddo
7047 enddo
7048
7049 ! Adjust pk
7050 ! ak & bk
7051 ! Adjusting model top to be a constant pressure surface, assuming isothermal atmosphere
7052 ! pe = ak + bk*ps
7053 ! One pressure layer
7054 pe1(1) = ptop
7055 ak(1) = ptop
7056 pint = pe1(2)
7057 bk(1) = 0.
7058 ak(2) = pint
7059 bk(2) = 0.
7060 do k=3,km+1
7061 bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma
7062 ak(k) = pe1(k) - bk(k) * pe1(km+1)
7063 if ( is_master() ) write(*,*) k, ak(k), bk(k)
7064 enddo
7065 ak(km+1) = 0.
7066 bk(km+1) = 1.
7067 do j=js, je
7068 do i=is, ie
7069 pe(i,1,j) = ptop
7070 enddo
7071 enddo
7072
7073
7074 end subroutine balanced_K
7075
7076 subroutine SuperK_u(km, zz, um, dudz)
7077 integer, intent(in):: km
7078 real, intent(in):: zz(km)
7079 real, intent(out):: um(km), dudz(km)
7080 ! Local
7081 real, parameter:: zs = 5.e3
7082 real, parameter:: us = 30.
7083 real:: uc = 15.
7084 integer k
7085
7086 do k=1, km
7087 #ifndef TEST_TANHP
7088 ! MPAS specification:
7089 if ( zz(k) .gt. zs+1.e3 ) then
7090 um(k) = us
7091 dudz(k) = 0.
7092 elseif ( abs(zz(k)-zs) .le. 1.e3 ) then
7093 um(k) = us*(-4./5. + 3.*zz(k)/zs - 5./4.*(zz(k)/zs)**2)
7094 dudz(k) = us/zs*(3. - 5./2.*zz(k)/zs)
7095 else
7096 um(k) = us*zz(k)/zs
7097 dudz(k) = us/zs
7098 endif
7099 ! constant wind so as to make the storm relatively stationary
7100 um(k) = um(k) - uc
7101 #else
7102 uc = 12. ! this gives near stationary (in longitude) storms
7103 um(k) = us*tanh( zz(k)/zs ) - uc
7104 dudz(k) = (us/zs)/cosh(zz(k)/zs)**2
7105 #endif
7106 enddo
7107
7108 end subroutine superK_u
7109
7110
7111 subroutine DCMIP16_BC(delp,pt,u,v,q,w,delz,&
7112 is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7113 pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7114 hydrostatic, nwat, adiabatic, do_pert, domain)
7115
7116 integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7117 real, intent(IN) :: ptop
7118 real, intent(IN), dimension(npz+1) :: ak, bk
7119 real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7120 real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz
7121 real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7122 real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7123 real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7124 real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7125 real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7126 real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7127 real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7128 real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7129 real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7130 real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7131 logical, intent(IN) :: hydrostatic,adiabatic,do_pert
7132 type(domain2d), intent(INOUT) :: domain
7133
7134 real, parameter :: p0 = 1.e5
7135 real, parameter :: u0 = 35.
7136 real, parameter :: b = 2.
7137 real, parameter :: KK = 3.
7138 real, parameter :: Te = 310.
7139 real, parameter :: Tp = 240.
7140 real, parameter :: T0 = 0.5*(Te + Tp) !!WRONG in document
7141 real, parameter :: up = 1.
7142 real, parameter :: zp = 1.5e4
7143 real(kind=R_GRID), parameter :: lamp = pi/9.
7144 real(kind=R_GRID), parameter :: phip = 2.*lamp
7145 real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7146 real, parameter :: Rp = radius/10.
7147 real, parameter :: lapse = 5.e-3
7148 real, parameter :: dT = 4.8e5
7149 real, parameter :: phiW = 2.*pi/9.
7150 real, parameter :: pW = 34000.
7151 real, parameter :: q0 = .018
7152 real, parameter :: qt = 1.e-12
7153 real, parameter :: ptrop = 1.e4
7154
7155 real, parameter :: zconv = 1.e-6
7156 real, parameter :: rdgrav = rdgas/grav
7157 real, parameter :: zvir = rvgas/rdgas - 1.
7158 real, parameter :: rrdgrav = grav/rdgas
7159
7160 integer :: i,j,k,iter, sphum, cl, cl2, n
7161 real :: p,z,z0,ziter,piter,titer,uu,vv,pl,pt_u,pt_v
7162 real(kind=R_GRID), dimension(2) :: pa
7163 real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7164 real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2
7165 real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7166 real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2
7167 real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7168
7169 !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7170 ! (with or without perturbation), moisture, Terminator tracer, w, delz
7171
7172 !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7173 ! and meridional winds on both grids, and rotate as needed
7174
7175 !PS
7176 do j=js,je
7177 do i=is,ie
7178 ps(i,j) = p0
7179 enddo
7180 enddo
7181
7182 !delp
7183 do k=1,npz
7184 do j=js,je
7185 do i=is,ie
7186 delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7187 enddo
7188 enddo
7189 enddo
7190
7191 !Pressure variables
7192 do j=js,je
7193 do i=is,ie
7194 pe(i,1,j) = ptop
7195 enddo
7196 do i=is,ie
7197 peln(i,1,j) = log(ptop)
7198 pk(i,j,1) = ptop**kappa
7199 enddo
7200 do k=2,npz+1
7201 do i=is,ie
7202 pe(i,k,j) = ak(k) + ps (i,j)*bk(k)
7203 enddo
7204 do i=is,ie
7205 pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7206 peln(i,k,j) = log(pe(i,k,j))
7207 enddo
7208 enddo
7209 enddo
7210
7211 do k=1,npz
7212 do j=js,je
7213 do i=is,ie
7214 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7215 enddo
7216 enddo
7217 enddo
7218
7219 !Height: Use Newton's method
7220 !Cell centered
7221 do j=js,je
7222 do i=is,ie
7223 phis(i,j) = 0.
7224 gz(i,j,npz+1) = 0.
7225 enddo
7226 enddo
7227 do k=npz,1,-1
7228 do j=js,je
7229 do i=is,ie
7230 p = pe(i,k,j)
7231 z = gz(i,j,k+1)
7232 do iter=1,30
7233 ziter = z
7234 piter = DCMIP16_BC_pressure(ziter,agrid(i,j,2))
7235 titer = DCMIP16_BC_temperature(ziter,agrid(i,j,2))
7236 z = ziter + (piter - p)*rdgrav*titer/piter
7237 !!$ !!! DEBUG CODE
7238 !!$ if (is_master() .and. i == is .and. j == js) then
7239 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7240 !!$ endif
7241 !!$ !!! END DEBUG CODE
7242 if (abs(z - ziter) < zconv) exit
7243 enddo
7244 gz(i,j,k) = z
7245 enddo
7246 enddo
7247 enddo
7248
7249 !Temperature: Compute from hydro balance
7250 do k=1,npz
7251 do j=js,je
7252 do i=is,ie
7253 pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7254 enddo
7255 enddo
7256 enddo
7257
7258 !Compute height and temperature for u and v points also, to be able to compute the local winds
7259 !Use temporary 2d arrays for this purpose
7260 do j=js,je+1
7261 do i=is,ie
7262 gz_u(i,j) = 0.
7263 p_u(i,j) = p0
7264 peln_u(i,j) = log(p0)
7265 ps_u(i,j) = p0
7266 call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7267 lat_u(i,j) = pa(2)
7268 lon_u(i,j) = pa(1)
7269 call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7270 call get_latlon_vector(pa,ex,ey)
7271 u1(i,j) = inner_prod(e1,ex) !u components
7272 u2(i,j) = inner_prod(e1,ey)
7273 enddo
7274 enddo
7275 do k=npz,1,-1
7276 do j=js,je+1
7277 do i=is,ie
7278 !Pressure (Top of interface)
7279 p = ak(k) + ps_u(i,j)*bk(k)
7280 pl = log(p)
7281 !Height (top of interface); use newton's method
7282 z = gz_u(i,j) !first guess, height of lower level
7283 z0 = z
7284 do iter=1,30
7285 ziter = z
7286 piter = DCMIP16_BC_pressure(ziter,lat_u(i,j))
7287 titer = DCMIP16_BC_temperature(ziter,lat_u(i,j))
7288 z = ziter + (piter - p)*rdgrav*titer/piter
7289 if (abs(z - ziter) < zconv) exit
7290 enddo
7291 !Temperature, compute from hydro balance
7292 pt_u = rrdgrav * ( z - gz_u(i,j) ) / (peln_u(i,j) - pl)
7293 !Now compute winds. Note no meridional winds
7294 !!!NOTE: do we need to use LAYER-mean z?
7295 uu = DCMIP16_BC_uwind(0.5*(z+z0),pt_u,lat_u(i,j))
7296 if (do_pert) then
7297 uu = uu + DCMIP16_BC_uwind_pert(0.5*(z+z0),lat_u(i,j),lon_u(i,j))
7298 endif
7299 u(i,j,k) = u1(i,j)*uu
7300
7301 gz_u(i,j) = z
7302 p_u(i,j) = p
7303 peln_u(i,j) = pl
7304 enddo
7305 enddo
7306 enddo
7307
7308 do j=js,je
7309 do i=is,ie+1
7310 gz_v(i,j) = 0.
7311 p_v(i,j) = p0
7312 peln_v(i,j) = log(p0)
7313 ps_v(i,j) = p0
7314 call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7315 lat_v(i,j) = pa(2)
7316 lon_v(i,j) = pa(1)
7317 call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7318 call get_latlon_vector(pa,ex,ey)
7319 v1(i,j) = inner_prod(e2,ex) !v components
7320 v2(i,j) = inner_prod(e2,ey)
7321 enddo
7322 enddo
7323 do k=npz,1,-1
7324 do j=js,je
7325 do i=is,ie+1
7326 !Pressure (Top of interface)
7327 p = ak(k) + ps_v(i,j)*bk(k)
7328 pl = log(p)
7329 !Height (top of interface); use newton's method
7330 z = gz_v(i,j) !first guess, height of lower level
7331 z0 = z
7332 do iter=1,30
7333 ziter = z
7334 piter = DCMIP16_BC_pressure(ziter,lat_v(i,j))
7335 titer = DCMIP16_BC_temperature(ziter,lat_v(i,j))
7336 z = ziter + (piter - p)*rdgrav*titer/piter
7337 if (abs(z - ziter) < zconv) exit
7338 enddo
7339 !Temperature, compute from hydro balance
7340 pt_v = rrdgrav * ( z - gz_v(i,j) ) / (peln_v(i,j) - pl)
7341 !Now compute winds
7342 uu = DCMIP16_BC_uwind(0.5*(z+z0),pt_v,lat_v(i,j))
7343 if (do_pert) then
7344 uu = uu + DCMIP16_BC_uwind_pert(0.5*(z+z0),lat_v(i,j),lon_v(i,j))
7345 endif
7346 v(i,j,k) = v1(i,j)*uu
7347 gz_v(i,j) = z
7348 p_v(i,j) = p
7349 peln_v(i,j) = pl
7350 enddo
7351 enddo
7352 enddo
7353
7354 !Compute moisture and other tracer fields, as desired
7355 do n=1,nq
7356 do k=1,npz
7357 do j=jsd,jed
7358 do i=isd,ied
7359 q(i,j,k,n) = 0.
7360 enddo
7361 enddo
7362 enddo
7363 enddo
7364 if (.not. adiabatic) then
7365 sphum = get_tracer_index (MODEL_ATMOS, 'sphum')
7366 do k=1,npz
7367 do j=js,je
7368 do i=is,ie
7369 p = delp(i,j,k)/(peln(i,k+1,j) - peln(i,k,j))
7370 q(i,j,k,sphum) = DCMIP16_BC_sphum(p,ps(i,j),agrid(i,j,2),agrid(i,j,1))
7371 !Convert pt to non-virtual temperature
7372 pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum))
7373 enddo
7374 enddo
7375 enddo
7376 endif
7377
7378 cl = get_tracer_index(MODEL_ATMOS, 'cl')
7379 cl2 = get_tracer_index(MODEL_ATMOS, 'cl2')
7380 if (cl > 0 .and. cl2 > 0) then
7381 call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
7382 q, delp,nq,agrid(isd,jsd,1),agrid(isd,jsd,2))
7383 call mpp_update_domains(q,domain)
7384 endif
7385
7386 !Compute nonhydrostatic variables, if needed
7387 if (.not. hydrostatic) then
7388 do k=1,npz
7389 do j=js,je
7390 do i=is,ie
7391 w(i,j,k) = 0.
7392 delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
7393 enddo
7394 enddo
7395 enddo
7396 endif
7397
7398 contains
7399
7400
7401 real function DCMIP16_BC_temperature(z, lat)
7402
7403 real, intent(IN) :: z
7404 real(kind=R_GRID), intent(IN) :: lat
7405 real :: IT, T1, T2, Tr, zsc
7406
7407 IT = exp(KK * log(cos(lat))) - KK/(KK+2.)*exp((KK+2.)*log(cos(lat)))
7408 zsc = z*grav/(b*Rdgas*T0)
7409 Tr = ( 1. - 2.*zsc**2.) * exp(-zsc**2. )
7410
7411 T1 = (1./T0)*exp(lapse*z/T0) + (T0 - Tp)/(T0*Tp) * Tr
7412 T2 = 0.5* ( KK + 2.) * (Te - Tp)/(Te*Tp) * Tr
7413
7414 DCMIP16_BC_temperature = 1./(T1 - T2*IT)
7415
7416 end function DCMIP16_BC_temperature
7417
7418 real function DCMIP16_BC_pressure(z,lat)
7419
7420 real, intent(IN) :: z
7421 real(kind=R_GRID), intent(IN) :: lat
7422 real :: IT, Ti1, Ti2, Tir
7423
7424 IT = exp(KK * log(cos(lat))) - KK/(KK+2.)*exp((KK+2.)*log(cos(lat)))
7425 Tir = z*exp(-(z*grav/(b*Rdgas*T0))*(z*grav/(b*Rdgas*T0)) )
7426
7427 Ti1 = 1./lapse* (exp(lapse*z/T0) - 1.) + Tir*(T0-Tp)/(T0*Tp)
7428 Ti2 = 0.5*(KK+2.)*(Te-Tp)/(Te*Tp) * Tir
7429
7430 DCMIP16_BC_pressure = p0*exp(-grav/Rdgas * ( Ti1 - Ti2*IT))
7431
7432 end function DCMIP16_BC_pressure
7433
7434 real function DCMIP16_BC_uwind(z,T,lat)
7435
7436 real, intent(IN) :: z, T
7437 real(kind=R_GRID), intent(IN) :: lat
7438 real :: Tir, Ti2, UU, ur
7439
7440 Tir = z*exp(-(z*grav/(b*Rdgas*T0))*(z*grav/(b*Rdgas*T0)) )
7441 Ti2 = 0.5*(KK+2.)*(Te-Tp)/(Te*Tp) * Tir
7442
7443 UU = grav*KK/radius * Ti2 * ( cos(lat)**(int(KK)-1) - cos(lat)**(int(KK)+1) ) * T
7444 ur = - omega * radius * cos(lat) + sqrt( (omega*radius*cos(lat))**2 + radius*cos(lat)*UU)
7445
7446 DCMIP16_BC_uwind = ur
7447
7448 end function DCMIP16_BC_uwind
7449
7450 real function DCMIP16_BC_uwind_pert(z,lat,lon)
7451
7452 real, intent(IN) :: z
7453 real(kind=R_GRID), intent(IN) :: lat, lon
7454 real :: ZZ, zrat
7455 real(kind=R_GRID) :: dst, pphere(2)
7456
7457 zrat = z/zp
7458 ZZ = max(1. - 3.*zrat*zrat + 2.*zrat*zrat*zrat, 0.)
7459
7460 pphere = (/ lon, lat /)
7461 dst = great_circle_dist(pphere, ppcenter, radius)
7462
7463 DCMIP16_BC_uwind_pert = max(0., up*ZZ*exp(-(dst/Rp)**2) )
7464
7465 end function DCMIP16_BC_uwind_pert
7466
7467 real function DCMIP16_BC_sphum(p,ps,lat, lon)
7468
7469 real, intent(IN) :: p, ps
7470 real(kind=R_GRID), intent(IN) :: lat, lon
7471 real :: eta
7472
7473 eta = p/ps
7474
7475 DCMIP16_BC_sphum = qt
7476 if (p > ptrop) then
7477 DCMIP16_BC_sphum = q0 * exp(-(lat/phiW)**4) * exp(-( (eta-1.)*p0/pw)**2)
7478 endif
7479
7480 end function DCMIP16_BC_sphum
7481
7482 end subroutine DCMIP16_BC
7483
7484 subroutine DCMIP16_TC(delp,pt,u,v,q,w,delz,&
7485 is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7486 pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7487 hydrostatic, nwat, adiabatic)
7488
7489 integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7490 real, intent(IN) :: ptop
7491 real, intent(IN), dimension(npz+1) :: ak, bk
7492 real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7493 real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz
7494 real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7495 real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7496 real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7497 real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7498 real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7499 real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7500 real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7501 real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7502 real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7503 real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7504 logical, intent(IN) :: hydrostatic,adiabatic
7505
7506 real, parameter :: zt = 15000 !< m
7507 real, parameter :: q0 = 0.021 !< kg/kg
7508 real, parameter :: qt = 1.e-11 !< kg/kg
7509 real, parameter :: T0 = 302.15 !< K
7510 real, parameter :: Tv0 = 302.15*(1.+0.608*q0) !< K
7511 real, parameter :: Ts = 302.15 !< K
7512 real, parameter :: zq1 = 3000. !< m
7513 real, parameter :: zq2 = 8000. !< m
7514 real, parameter :: lapse = 7.e-3 !< K/m
7515 real, parameter :: Tvt = Tv0 - lapse*zt !< K
7516 real, parameter :: pb = 101500. !< Pa
7517 real, parameter :: ptt = pb*(TvT/Tv0)**(grav/Rdgas/lapse)
7518 real(kind=R_GRID), parameter :: lamp = pi
7519 real(kind=R_GRID), parameter :: phip = pi/18.
7520 real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7521 real, parameter :: dp = 1115. !< Pa
7522 real, parameter :: rp = 282000. !< m
7523 real, parameter :: zp = 7000. !< m
7524 real, parameter :: fc = 2.*OMEGA*sin(phip)
7525
7526 real, parameter :: zconv = 1.e-6
7527 real, parameter :: rdgrav = rdgas/grav
7528 real, parameter :: rrdgrav = grav/rdgas
7529
7530 integer :: i,j,k,iter, sphum, cl, cl2, n
7531 real :: p,z,z0,ziter,piter,titer,uu,vv,pl, r
7532 real(kind=R_GRID), dimension(2) :: pa
7533 real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7534 real, dimension(is:ie,js:je) :: rc
7535 real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2, rc_u
7536 real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7537 real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2, rc_v
7538 real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7539
7540 !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7541 ! (with or without perturbation), moisture, w, delz
7542
7543 !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7544 ! and meridional winds on both grids, and rotate as needed
7545
7546 !Save r for easy use
7547 do j=js,je
7548 do i=is,ie
7549 rc(i,j) = great_circle_dist(agrid(i,j,:), ppcenter, radius)
7550 enddo
7551 enddo
7552
7553 !PS
7554 do j=js,je
7555 do i=is,ie
7556 ps(i,j) = pb - dp*exp( -sqrt((rc(i,j)/rp)**3) )
7557 enddo
7558 enddo
7559
7560 !delp
7561 do k=1,npz
7562 do j=js,je
7563 do i=is,ie
7564 delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7565 enddo
7566 enddo
7567 enddo
7568
7569 !Pressure variables
7570 do j=js,je
7571 do i=is,ie
7572 pe(i,1,j) = ptop
7573 enddo
7574 do i=is,ie
7575 peln(i,1,j) = log(ptop)
7576 pk(i,j,1) = ptop**kappa
7577 enddo
7578 do k=2,npz+1
7579 do i=is,ie
7580 pe(i,k,j) = ak(k) + ps (i,j)*bk(k)
7581 enddo
7582 do i=is,ie
7583 pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7584 peln(i,k,j) = log(pe(i,k,j))
7585 enddo
7586 enddo
7587 enddo
7588
7589 do k=1,npz
7590 do j=js,je
7591 do i=is,ie
7592 pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7593 enddo
7594 enddo
7595 enddo
7596
7597 !Height: Use Newton's method
7598 !Cell centered
7599 do j=js,je
7600 do i=is,ie
7601 phis(i,j) = 0.
7602 gz(i,j,npz+1) = 0.
7603 enddo
7604 enddo
7605 do k=npz,1,-1
7606 do j=js,je
7607 do i=is,ie
7608 p = pe(i,k,j)
7609 z = gz(i,j,k+1)
7610 do iter=1,30
7611 ziter = z
7612 piter = DCMIP16_TC_pressure(ziter,rc(i,j))
7613 titer = DCMIP16_TC_temperature(ziter,rc(i,j))
7614 z = ziter + (piter - p)*rdgrav*titer/piter
7615 !!$ !!! DEBUG CODE
7616 !!$ if (is_master() .and. i == is .and. j == js) then
7617 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7618 !!$ endif
7619 !!$ !!! END DEBUG CODE
7620 if (abs(z - ziter) < zconv) exit
7621 enddo
7622 gz(i,j,k) = z
7623 enddo
7624 enddo
7625 enddo
7626
7627 !Temperature: Compute from hydro balance
7628 do k=1,npz
7629 do j=js,je
7630 do i=is,ie
7631 pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7632 enddo
7633 enddo
7634 enddo
7635
7636 !Compute height and temperature for u and v points also, to be able to compute the local winds
7637 !Use temporary 2d arrays for this purpose
7638 do j=js,je+1
7639 do i=is,ie
7640 call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7641 lat_u(i,j) = pa(2)
7642 lon_u(i,j) = pa(1)
7643 call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7644 call get_latlon_vector(pa,ex,ey)
7645 u1(i,j) = inner_prod(e1,ex) !u components
7646 u2(i,j) = inner_prod(e1,ey)
7647 rc_u(i,j) = great_circle_dist(pa, ppcenter, radius)
7648 gz_u(i,j) = 0.
7649 p_u(i,j) = pb - dp*exp( -sqrt((rc_u(i,j)/rp)**3) )
7650 peln_u(i,j) = log(p_u(i,j))
7651 ps_u(i,j) = p_u(i,j)
7652 enddo
7653 enddo
7654 do k=npz,1,-1
7655 do j=js,je+1
7656 do i=is,ie
7657 !Pressure (Top of interface)
7658 p = ak(k) + ps_u(i,j)*bk(k)
7659 pl = log(p)
7660 !Height (top of interface); use newton's method
7661 z = gz_u(i,j) !first guess, height of lower level
7662 z0 = z
7663 do iter=1,30
7664 ziter = z
7665 piter = DCMIP16_TC_pressure(ziter,rc_u(i,j))
7666 titer = DCMIP16_TC_temperature(ziter,rc_u(i,j))
7667 z = ziter + (piter - p)*rdgrav*titer/piter
7668 if (abs(z - ziter) < zconv) exit
7669 enddo
7670 !Now compute winds
7671 call DCMIP16_TC_uwind_pert(0.5*(z+z0),rc_u(i,j),lon_u(i,j),lat_u(i,j), uu, vv)
7672 u(i,j,k) = u1(i,j)*uu + u2(i,j)*vv
7673
7674 gz_u(i,j) = z
7675 p_u(i,j) = p
7676 peln_u(i,j) = pl
7677 enddo
7678 enddo
7679 enddo
7680
7681 do j=js,je
7682 do i=is,ie+1
7683 call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7684 lat_v(i,j) = pa(2)
7685 lon_v(i,j) = pa(1)
7686 call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7687 call get_latlon_vector(pa,ex,ey)
7688 v1(i,j) = inner_prod(e2,ex) !v components
7689 v2(i,j) = inner_prod(e2,ey)
7690 rc_v(i,j) = great_circle_dist(pa, ppcenter, radius)
7691 gz_v(i,j) = 0.
7692 p_v(i,j) = pb - dp*exp( - sqrt((rc_v(i,j)/rp)**3) )
7693 peln_v(i,j) = log(p_v(i,j))
7694 ps_v(i,j) = p_v(i,j)
7695 enddo
7696 enddo
7697 do k=npz,1,-1
7698 do j=js,je
7699 do i=is,ie+1
7700 !Pressure (Top of interface)
7701 p = ak(k) + ps_v(i,j)*bk(k)
7702 pl = log(p)
7703 !Height (top of interface); use newton's method
7704 z = gz_v(i,j) !first guess, height of lower level
7705 z0 = z
7706 do iter=1,30
7707 ziter = z
7708 piter = DCMIP16_TC_pressure(ziter,rc_v(i,j))
7709 titer = DCMIP16_TC_temperature(ziter,rc_v(i,j))
7710 z = ziter + (piter - p)*rdgrav*titer/piter
7711 if (abs(z - ziter) < zconv) exit
7712 enddo
7713 !Now compute winds
7714 call DCMIP16_TC_uwind_pert(0.5*(z+z0),rc_v(i,j),lon_v(i,j),lat_v(i,j), uu, vv)
7715 v(i,j,k) = v1(i,j)*uu + v2(i,j)*vv
7716 gz_v(i,j) = z
7717 p_v(i,j) = p
7718 peln_v(i,j) = pl
7719 enddo
7720 enddo
7721 enddo
7722
7723 !Compute moisture and other tracer fields, as desired
7724 do n=1,nq
7725 do k=1,npz
7726 do j=jsd,jed
7727 do i=isd,ied
7728 q(i,j,k,n) = 0.
7729 enddo
7730 enddo
7731 enddo
7732 enddo
7733 if (.not. adiabatic) then
7734 sphum = get_tracer_index (MODEL_ATMOS, 'sphum')
7735 do k=1,npz
7736 do j=js,je
7737 do i=is,ie
7738 z = 0.5*(gz(i,j,k) + gz(i,j,k+1))
7739 q(i,j,k,sphum) = DCMIP16_TC_sphum(z)
7740 enddo
7741 enddo
7742 enddo
7743 endif
7744
7745 !Compute nonhydrostatic variables, if needed
7746 if (.not. hydrostatic) then
7747 do k=1,npz
7748 do j=js,je
7749 do i=is,ie
7750 w(i,j,k) = 0.
7751 delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
7752 enddo
7753 enddo
7754 enddo
7755 endif
7756
7757 contains
7758
7759 !Initialize with virtual temperature
7760 real function DCMIP16_TC_temperature(z, r)
7761
7762 real, intent(IN) :: z, r
7763 real :: Tv, term1, term2
7764
7765 if (z > zt) then
7766 DCMIP16_TC_temperature = Tvt
7767 return
7768 endif
7769
7770 Tv = Tv0 - lapse*z
7771 term1 = grav*zp*zp* ( 1. - pb/dp * exp( sqrt(r/rp)**3 + (z/zp)**2 ) )
7772 term2 = 2*rdgas*Tv*z
7773 DCMIP16_TC_temperature = Tv + Tv*( 1./(1 + term2/term1) - 1.)
7774
7775 end function DCMIP16_TC_temperature
7776
7777 !Initialize with moist air mass
7778 real function DCMIP16_TC_pressure(z, r)
7779
7780 real, intent(IN) :: z, r
7781
7782 if (z <= zt) then
7783 DCMIP16_TC_pressure = pb*exp(grav/(Rdgas*lapse) * log( (Tv0-lapse*z)/Tv0) ) -dp* exp(-sqrt((r/rp)**3) - (z/zp)**2) * &
7784 exp( grav/(Rdgas*lapse) * log( (Tv0-lapse*z)/Tv0) )
7785 else
7786 DCMIP16_TC_pressure = ptt*exp(grav*(zt-z)/(Rdgas*Tvt))
7787 endif
7788
7789 end function DCMIP16_TC_pressure
7790
7791 subroutine DCMIP16_TC_uwind_pert(z,r,lon,lat,uu,vv)
7792
7793 real, intent(IN) :: z, r
7794 real(kind=R_GRID), intent(IN) :: lon, lat
7795 real, intent(OUT) :: uu, vv
7796 real :: rfac, Tvrd, vt, fr5, d1, d2, d
7797 real(kind=R_GRID) :: dst, pphere(2)
7798
7799 if (z > zt) then
7800 uu = 0.
7801 vv = 0.
7802 return
7803 endif
7804
7805 rfac = sqrt(r/rp)**3
7806
7807 fr5 = 0.5*fc*r
7808 Tvrd = (Tv0 - lapse*z)*Rdgas
7809
7810 vt = -fr5 + sqrt( fr5**2 - (1.5 * rfac * Tvrd) / &
7811 ( 1. + 2*Tvrd*z/(grav*zp**2) - pb/dp*exp( rfac + (z/zp)**2) ) )
7812
7813 d1 = sin(phip)*cos(lat) - cos(phip)*sin(lat)*cos(lon - lamp)
7814 d2 = cos(phip)*sin(lon - lamp)
7815 d = max(1.e-25,sqrt(d1*d1 + d2*d2))
7816
7817 uu = vt * d1/d
7818 vv = vt * d2/d
7819
7820 end subroutine DCMIP16_TC_uwind_pert
7821
7822 real function DCMIP16_TC_sphum(z)
7823
7824 real, intent(IN) :: z
7825
7826 DCMIP16_TC_sphum = qt
7827 if (z < zt) then
7828 DCMIP16_TC_sphum = q0 * exp(-z/zq1) * exp(-(z/zq2 )**2)
7829 endif
7830
7831 end function DCMIP16_TC_sphum
7832
7833 end subroutine DCMIP16_TC
7834
7835 subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
7836 gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, &
7837 mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in)
7838
7839 real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
7840 real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
7841 real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
7842 real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
7843 real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
7844
7845 real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
7846
7847 real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
7848 real , intent(INOUT) :: pe(is-1:ie+1,npz+1,js-1:je+1)
7849 real , intent(INOUT) :: pk(is:ie ,js:je ,npz+1)
7850 real , intent(INOUT) :: peln(is :ie ,npz+1 ,js:je)
7851 real , intent(INOUT) :: pkz(is:ie ,js:je ,npz )
7852 real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
7853 real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
7854 real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
7855 real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
7856 real , intent(inout) :: delz(isd:,jsd:,1:)
7857 real , intent(inout) :: ze0(is:,js:,1:)
7858
7859 real , intent(IN) :: ak(npz+1)
7860 real , intent(IN) :: bk(npz+1)
7861
7862 integer, intent(IN) :: npx, npy, npz
7863 integer, intent(IN) :: ng, ncnst
7864 integer, intent(IN) :: ndims
7865 integer, intent(IN) :: nregions
7866 integer,target,intent(IN):: tile_in
7867
7868 real, intent(IN) :: dry_mass
7869 logical, intent(IN) :: mountain
7870 logical, intent(IN) :: moist_phys
7871 logical, intent(IN) :: hybrid_z
7872
7873 type(fv_grid_type), intent(IN), target :: gridstruct
7874 type(domain2d), intent(IN), target :: domain_in
7875
7876 real, pointer, dimension(:,:,:) :: agrid, grid
7877 real, pointer, dimension(:,:) :: area, rarea, fC, f0
7878 real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
7879 real, pointer, dimension(:,:,:,:) :: ew, es
7880 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
7881
7882 logical, pointer :: cubed_sphere, latlon
7883
7884 type(domain2d), pointer :: domain
7885 integer, pointer :: tile
7886
7887 logical, pointer :: have_south_pole, have_north_pole
7888
7889 integer, pointer :: ntiles_g
7890 real, pointer :: acapN, acapS, globalarea
7891
7892 real(kind=R_GRID) :: p1(2), p2(2)
7893 real :: r, r0
7894 integer :: i,j
7895
7896 agrid => gridstruct%agrid
7897 grid => gridstruct%grid
7898
7899 area => gridstruct%area
7900
7901 dx => gridstruct%dx
7902 dy => gridstruct%dy
7903 dxa => gridstruct%dxa
7904 dya => gridstruct%dya
7905 rdxa => gridstruct%rdxa
7906 rdya => gridstruct%rdya
7907 dxc => gridstruct%dxc
7908 dyc => gridstruct%dyc
7909
7910 fC => gridstruct%fC
7911 f0 => gridstruct%f0
7912
7913 ntiles_g => gridstruct%ntiles_g
7914 acapN => gridstruct%acapN
7915 acapS => gridstruct%acapS
7916 globalarea => gridstruct%globalarea
7917
7918 domain => domain_in
7919 tile => tile_in
7920
7921 have_south_pole => gridstruct%have_south_pole
7922 have_north_pole => gridstruct%have_north_pole
7923
7924 do j=jsd,jed+1
7925 do i=isd,ied+1
7926 fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) &
7927 +sin(grid(i,j,2))*cos(alpha) )
7928 enddo
7929 enddo
7930 do j=jsd,jed
7931 do i=isd,ied
7932 f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) &
7933 +sin(agrid(i,j,2))*cos(alpha) )
7934 enddo
7935 enddo
7936
7937 select case (test_case)
7938 case ( 1 )
7939
7940 Ubar = (2.0*pi*radius)/(12.0*86400.0)
7941 phis = 0.0
7942 r0 = radius/3. !RADIUS radius/3.
7943 !!$ p1(1) = 0.
7944 p1(1) = pi/2. + pi_shift
7945 p1(2) = 0.
7946 do j=jsd,jed
7947 do i=isd,ied
7948 p2(1) = agrid(i,j,1)
7949 p2(2) = agrid(i,j,2)
7950 r = great_circle_dist( p1, p2, radius )
7951 if (r < r0) then
7952 delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(PI*r/r0))
7953 else
7954 delp(i,j,1) = phis(i,j)
7955 endif
7956 enddo
7957 enddo
7958 call init_latlon_winds(UBar, u, v, ua, va, uc, vc, 1, gridstruct)
7959
7960
7961 !!$ phis(:,:)=0.
7962 !!$
7963 !!$ u (:,:,:)=10.
7964 !!$ v (:,:,:)=10.
7965 !!$ ua(:,:,:)=10.
7966 !!$ va(:,:,:)=10.
7967 !!$ uc(:,:,:)=10.
7968 !!$ vc(:,:,:)=10.
7969 !!$ pt(:,:,:)=1.
7970 !!$ delp(:,:,:)=0.
7971 !!$
7972 !!$ do j=js,je
7973 !!$ if (j>10 .and. j<15) then
7974 !!$ do i=is,ie
7975 !!$ if (i>10 .and. i<15) then
7976 !!$ delp(i,j,:)=1.
7977 !!$ endif
7978 !!$ enddo
7979 !!$ endif
7980 !!$ enddo
7981 !!$ call mpp_update_domains( delp, domain )
7982
7983 end select
7984
7985 nullify(grid)
7986 nullify(agrid)
7987
7988 nullify(area)
7989
7990 nullify(fC)
7991 nullify(f0)
7992
7993 nullify(dx)
7994 nullify(dy)
7995 nullify(dxa)
7996 nullify(dya)
7997 nullify(rdxa)
7998 nullify(rdya)
7999 nullify(dxc)
8000 nullify(dyc)
8001
8002 nullify(domain)
8003 nullify(tile)
8004
8005 nullify(have_south_pole)
8006 nullify(have_north_pole)
8007
8008 nullify(ntiles_g)
8009 nullify(acapN)
8010 nullify(acapS)
8011 nullify(globalarea)
8012
8013 end subroutine init_latlon
8014
8015 subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct)
8016
8017 ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate
8018
8019 real, intent(INOUT) :: UBar
8020 real, intent(INOUT) :: u(isd:ied ,jsd:jed+1)
8021 real, intent(INOUT) :: v(isd:ied+1,jsd:jed )
8022 real, intent(INOUT) :: uc(isd:ied+1,jsd:jed )
8023 real, intent(INOUT) :: vc(isd:ied ,jsd:jed+1)
8024 real, intent(INOUT) :: ua(isd:ied ,jsd:jed )
8025 real, intent(INOUT) :: va(isd:ied ,jsd:jed )
8026 integer, intent(IN) :: defOnGrid
8027 type(fv_grid_type), intent(IN), target :: gridstruct
8028
8029 real :: p1(2),p2(2),p3(2),p4(2), pt(2)
8030 real :: e1(3), e2(3), ex(3), ey(3)
8031
8032 real :: dist, r, r0
8033 integer :: i,j,k,n
8034 real :: utmp, vtmp
8035
8036 real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2
8037
8038 real, dimension(:,:,:), pointer :: grid, agrid
8039 real, dimension(:,:), pointer :: area, dx, dy, dxc, dyc
8040
8041 grid => gridstruct%grid
8042 agrid=> gridstruct%agrid
8043
8044 area => gridstruct%area
8045 dx => gridstruct%dx
8046 dy => gridstruct%dy
8047 dxc => gridstruct%dxc
8048 dyc => gridstruct%dyc
8049
8050 psi(:,:) = 1.e25
8051 psi_b(:,:) = 1.e25
8052 do j=jsd,jed
8053 do i=isd,ied
8054 psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
8055 cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
8056 enddo
8057 enddo
8058 do j=jsd,jed+1
8059 do i=isd,ied+1
8060 psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
8061 cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
8062 enddo
8063 enddo
8064
8065 if ( defOnGrid == 1 ) then
8066 do j=jsd,jed+1
8067 do i=isd,ied
8068 dist = dx(i,j)
8069 vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
8070 if (dist==0) vc(i,j) = 0.
8071 enddo
8072 enddo
8073 do j=jsd,jed
8074 do i=isd,ied+1
8075 dist = dy(i,j)
8076 uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
8077 if (dist==0) uc(i,j) = 0.
8078 enddo
8079 enddo
8080
8081
8082 do j=js,je
8083 do i=is,ie+1
8084 dist = dxc(i,j)
8085 v(i,j) = (psi(i,j)-psi(i-1,j))/dist
8086 if (dist==0) v(i,j) = 0.
8087 enddo
8088 enddo
8089 do j=js,je+1
8090 do i=is,ie
8091 dist = dyc(i,j)
8092 u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
8093 if (dist==0) u(i,j) = 0.
8094 enddo
8095 enddo
8096 endif
8097
8098 end subroutine init_latlon_winds
8099
8100 subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, nested, &
8101 u,v, ua,va, uc,vc, gridstruct, domain)
8102
8103 ! Input
8104 integer, intent(IN) :: im,jm,km
8105 integer, intent(IN) :: ifirst,ilast
8106 integer, intent(IN) :: jfirst,jlast
8107 integer, intent(IN) :: ng
8108 logical, intent(IN) :: nested
8109 type(fv_grid_type), intent(IN), target :: gridstruct
8110 type(domain2d), intent(INOUT) :: domain
8111
8112 !real , intent(in) :: sinlon(im,jm)
8113 !real , intent(in) :: coslon(im,jm)
8114 !real , intent(in) :: sinl5(im,jm)
8115 !real , intent(in) :: cosl5(im,jm)
8116
8117 ! Output
8118 ! real , intent(inout) :: u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8119 ! real , intent(inout) :: v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8120 ! real , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8121 ! real , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8122 ! real , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8123 ! real , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8124
8125 real , intent(inout) :: u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8126 real , intent(inout) :: v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8127 real , intent(inout) :: ua(isd:ied,jsd:jed) !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8128 real , intent(inout) :: va(isd:ied,jsd:jed) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8129 real , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8130 real , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8131
8132 !--------------------------------------------------------------
8133 ! Local
8134
8135 real :: sinlon(im,jm)
8136 real :: coslon(im,jm)
8137 real :: sinl5(im,jm)
8138 real :: cosl5(im,jm)
8139
8140 real :: tmp1(jsd:jed+1)
8141 real :: tmp2(jsd:jed)
8142 real :: tmp3(jsd:jed)
8143
8144 real mag,mag1,mag2, ang,ang1,ang2
8145 real us, vs, un, vn
8146 integer i, j, k, im2
8147 integer js1g1
8148 integer js2g1
8149 integer js2g2
8150 integer js2gc
8151 integer js2gc1
8152 integer js2gcp1
8153 integer js2gd
8154 integer jn2gc
8155 integer jn1g1
8156 integer jn1g2
8157 integer jn2gd
8158 integer jn2gsp1
8159
8160 real, pointer, dimension(:,:,:) :: agrid, grid
8161 real, pointer, dimension(:,:) :: area, rarea, fC, f0
8162 real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
8163 real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
8164 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8165
8166 logical, pointer :: cubed_sphere, latlon
8167
8168 logical, pointer :: have_south_pole, have_north_pole
8169
8170 integer, pointer :: ntiles_g
8171 real, pointer :: acapN, acapS, globalarea
8172
8173 grid => gridstruct%grid
8174 agrid=> gridstruct%agrid
8175
8176 area => gridstruct%area
8177 rarea => gridstruct%rarea
8178
8179 fC => gridstruct%fC
8180 f0 => gridstruct%f0
8181
8182 ee1 => gridstruct%ee1
8183 ee2 => gridstruct%ee2
8184 ew => gridstruct%ew
8185 es => gridstruct%es
8186 en1 => gridstruct%en1
8187 en2 => gridstruct%en2
8188
8189 dx => gridstruct%dx
8190 dy => gridstruct%dy
8191 dxa => gridstruct%dxa
8192 dya => gridstruct%dya
8193 rdxa => gridstruct%rdxa
8194 rdya => gridstruct%rdya
8195 dxc => gridstruct%dxc
8196 dyc => gridstruct%dyc
8197
8198 cubed_sphere => gridstruct%cubed_sphere
8199 latlon => gridstruct%latlon
8200
8201 have_south_pole => gridstruct%have_south_pole
8202 have_north_pole => gridstruct%have_north_pole
8203
8204 ntiles_g => gridstruct%ntiles_g
8205 acapN => gridstruct%acapN
8206 acapS => gridstruct%acapS
8207 globalarea => gridstruct%globalarea
8208
8209 if (cubed_sphere) then
8210
8211 call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,im,jm,ng)
8212 if (.not. nested) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.)
8213 call atoc(ua,va,uc,vc,dx,dy,dxa,dya,im,jm,ng, nested, domain, noComm=.true.)
8214 if (.not. nested) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.)
8215
8216 else ! Lat-Lon
8217
8218 im2 = im/2
8219
8220 ! Set loop limits
8221
8222 js1g1 = jfirst-1
8223 js2g1 = jfirst-1
8224 js2g2 = jfirst-2
8225 js2gc = jfirst-ng
8226 js2gcp1 = jfirst-ng-1
8227 js2gd = jfirst-ng
8228 jn1g1 = jlast+1
8229 jn1g2 = jlast+2
8230 jn2gc = jlast+ng
8231 jn2gd = jlast+ng-1
8232 jn2gsp1 = jlast+ng-1
8233
8234 if (have_south_pole) then
8235 js1g1 = 1
8236 js2g1 = 2
8237 js2g2 = 2
8238 js2gc = 2
8239 js2gcp1 = 2 ! NG-1 latitudes on S (starting at 2)
8240 js2gd = 2
8241 endif
8242 if (have_north_pole) then
8243 jn1g1 = jm
8244 jn1g2 = jm
8245 jn2gc = jm-1 ! NG latitudes on N (ending at jm-1)
8246 jn2gd = jm-1
8247 jn2gsp1 = jm-1
8248 endif
8249 !
8250 ! Treat the special case of ng = 1
8251 !
8252 if ( ng == 1 .AND. ng > 1 ) THEN
8253 js2gc1 = js2gc
8254 else
8255 js2gc1 = jfirst-ng+1
8256 if (have_south_pole) js2gc1 = 2 ! NG-1 latitudes on S (starting at 2)
8257 endif
8258
8259 do k=1,km
8260
8261 if ((have_south_pole) .or. (have_north_pole)) then
8262 ! Get D-grid V-wind at the poles.
8263 call vpol5(u(1:im,:), v(1:im,:), im, jm, &
8264 coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast )
8265 call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:))
8266 endif
8267
8268 call dtoa(u, v, ua, va, dx,dy,dxa,dya,dxc,dyc,im, jm, ng)
8269 if (.not. nested) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.)
8270
8271 if ( have_south_pole ) then
8272 ! Projection at SP
8273 us = 0.
8274 vs = 0.
8275 do i=1,im2
8276 us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2) &
8277 + (va(i,2)-va(i+im2,2))*coslon(i,2)
8278 vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2) &
8279 + (va(i+im2,2)-va(i,2))*sinlon(i,2)
8280 enddo
8281 us = us/im
8282 vs = vs/im
8283 ! SP
8284 do i=1,im2
8285 ua(i,1) = -us*sinlon(i,1) - vs*coslon(i,1)
8286 va(i,1) = us*coslon(i,1) - vs*sinlon(i,1)
8287 ua(i+im2,1) = -ua(i,1)
8288 va(i+im2,1) = -va(i,1)
8289 enddo
8290 ua(0 ,1) = ua(im,1)
8291 ua(im+1,1) = ua(1 ,1)
8292 va(im+1,1) = va(1 ,1)
8293 endif
8294
8295 if ( have_north_pole ) then
8296 ! Projection at NP
8297 un = 0.
8298 vn = 0.
8299 j = jm-1
8300 do i=1,im2
8301 un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j) &
8302 + (va(i+im2,j)-va(i,j))*coslon(i,j)
8303 vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j) &
8304 + (va(i+im2,j)-va(i,j))*sinlon(i,j)
8305 enddo
8306 un = un/im
8307 vn = vn/im
8308 ! NP
8309 do i=1,im2
8310 ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm)
8311 va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm)
8312 ua(i+im2,jm) = -ua(i,jm)
8313 va(i+im2,jm) = -va(i,jm)
8314 enddo
8315 ua(0 ,jm) = ua(im,jm)
8316 ua(im+1,jm) = ua(1 ,jm)
8317 va(im+1,jm) = va(1 ,jm)
8318 endif
8319
8320 if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:))
8321 if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:))
8322
8323 ! A -> C
8324 call atoc(ua, va, uc, vc, dx,dy,dxa,dya,im, jm, ng, nested, domain, noComm=.true.)
8325
8326 enddo ! km loop
8327
8328 if (.not. nested) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.)
8329 endif
8330
8331
8332 end subroutine d2a2c
8333
8334 subroutine atob_s(qin, qout, npx, npy, dxa, dya, nested, cubed_sphere, altInterp)
8335 integer, intent(IN) :: npx, npy
8336 real , intent(IN) :: qin(isd:ied ,jsd:jed ) !< A-grid field
8337 real , intent(OUT) :: qout(isd:ied+1,jsd:jed+1) !< Output B-grid field
8338 integer, OPTIONAL, intent(IN) :: altInterp
8339 logical, intent(IN) :: nested, cubed_sphere
8340 real, intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8341
8342 integer :: i,j,n
8343
8344 real :: tmp1j(jsd:jed+1)
8345 real :: tmp2j(jsd:jed+1)
8346 real :: tmp3j(jsd:jed+1)
8347 real :: tmp1i(isd:ied+1)
8348 real :: tmp2i(isd:ied+1)
8349 real :: tmp3i(isd:ied+1)
8350 real :: tmpq(isd:ied ,jsd:jed )
8351 real :: tmpq1(isd:ied+1,jsd:jed+1)
8352 real :: tmpq2(isd:ied+1,jsd:jed+1)
8353
8354 if (present(altInterp)) then
8355
8356 tmpq(:,:) = qin(:,:)
8357
8358 if (.not. nested) call fill_corners(tmpq , npx, npy, FILL=XDir, AGRID=.true.)
8359 ! ATOC
8360 do j=jsd,jed
8361 call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altInterp)
8362 enddo
8363
8364 if (.not. nested) call fill_corners(tmpq , npx, npy, FILL=YDir, AGRID=.true.)
8365 ! ATOD
8366 do i=isd,ied
8367 tmp1j(jsd:jed) = 0.0
8368 tmp2j(jsd:jed) = tmpq(i,jsd:jed)
8369 tmp3j(jsd:jed) = dya(i,jsd:jed)
8370 call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altInterp)
8371 tmpq2(i,jsd:jed) = tmp1j(jsd:jed)
8372 enddo
8373
8374 ! CTOB
8375 do i=isd,ied
8376 tmp1j(:) = tmpq1(i,:)
8377 tmp2j(:) = tmpq1(i,:)
8378 tmp3j(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8379 call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altInterp)
8380 tmpq1(i,:) = tmp1j(:)
8381 enddo
8382
8383 ! DTOB
8384 do j=jsd,jed
8385 tmp1i(:) = tmpq2(:,j)
8386 tmp2i(:) = tmpq2(:,j)
8387 tmp3i(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8388 call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altInterp)
8389 tmpq2(:,j) = tmp1i(:)
8390 enddo
8391
8392 ! Average
8393 do j=jsd,jed+1
8394 do i=isd,ied+1
8395 qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j))
8396 enddo
8397 enddo
8398
8399 ! Fix Corners
8400 if (cubed_sphere .and. .not. nested) then
8401 i=1
8402 j=1
8403 if ( (is==i) .and. (js==j) ) then
8404 qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8405 endif
8406
8407 i=npx
8408 j=1
8409 if ( (ie+1==i) .and. (js==j) ) then
8410 qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8411 endif
8412
8413 i=1
8414 j=npy
8415 if ( (is==i) .and. (je+1==j) ) then
8416 qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8417 endif
8418
8419 i=npx
8420 j=npy
8421 if ( (ie+1==i) .and. (je+1==j) ) then
8422 qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8423 endif
8424 endif
8425
8426 else ! altInterp
8427
8428 do j=js,je+1
8429 do i=is,ie+1
8430 qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + &
8431 qin(i ,j) + qin(i ,j-1))
8432 enddo
8433 enddo
8434
8435 if (.not. nested) then
8436 i=1
8437 j=1
8438 if ( (is==i) .and. (js==j) ) then
8439 qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8440 endif
8441
8442 i=npx
8443 j=1
8444 if ( (ie+1==i) .and. (js==j) ) then
8445 qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8446 endif
8447
8448 i=1
8449 j=npy
8450 if ( (is==i) .and. (je+1==j) ) then
8451 qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8452 endif
8453
8454 i=npx
8455 j=npy
8456 if ( (ie+1==i) .and. (je+1==j) ) then
8457 qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8458 endif
8459 endif !not nested
8460
8461 endif ! altInterp
8462
8463 end subroutine atob_s
8464 !
8465 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8466 !-------------------------------------------------------------------------------
8467
8468 !-------------------------------------------------------------------------------
8469 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8470 subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, nested, domain)
8471 integer, intent(IN) :: npx, npy, ng
8472 real , intent(IN) :: uin(isd:ied ,jsd:jed ) !< A-grid u-wind field
8473 real , intent(IN) :: vin(isd:ied ,jsd:jed ) !< A-grid v-wind field
8474 real , intent(OUT) :: uout(isd:ied ,jsd:jed+1) !< D-grid u-wind field
8475 real , intent(OUT) :: vout(isd:ied+1,jsd:jed ) !< D-grid v-wind field
8476 logical, intent(IN) :: nested
8477 real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8478 real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc
8479 real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc
8480 type(domain2d), intent(INOUT) :: domain
8481
8482 integer :: i,j
8483 real :: tmp1i(isd:ied+1)
8484 real :: tmp2i(isd:ied)
8485 real :: tmp3i(isd:ied)
8486 real :: tmp1j(jsd:jed+1)
8487 real :: tmp2j(jsd:jed)
8488 real :: tmp3j(jsd:jed)
8489
8490 do j=jsd+1,jed
8491 tmp1i(:) = 0.0
8492 tmp2i(:) = vin(:,j)*dxa(:,j)
8493 tmp3i(:) = dxa(:,j)
8494 call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interpOrder)
8495 vout(:,j) = tmp1i(:)/dxc(:,j)
8496 enddo
8497 do i=isd+1,ied
8498 tmp1j(:) = 0.0
8499 tmp2j(:) = uin(i,:)*dya(i,:)
8500 tmp3j(:) = dya(i,:)
8501 call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder)
8502 uout(i,:) = tmp1j(:)/dyc(i,:)
8503 enddo
8504 call mp_update_dwinds(uout, vout, npx, npy, domain)
8505 if (.not. nested) call fill_corners(uout, vout, npx, npy, VECTOR=.true., DGRID=.true.)
8506 end subroutine atod
8507 !
8508 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8509 !-------------------------------------------------------------------------------
8510
8511 !-------------------------------------------------------------------------------
8512 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8513 subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng)
8514 integer, intent(IN) :: npx, npy, ng
8515 real , intent(IN) :: uin(isd:ied ,jsd:jed+1) !< D-grid u-wind field
8516 real , intent(IN) :: vin(isd:ied+1,jsd:jed ) !< D-grid v-wind field
8517 real , intent(OUT) :: uout(isd:ied ,jsd:jed ) !< A-grid u-wind field
8518 real , intent(OUT) :: vout(isd:ied ,jsd:jed ) !< A-grid v-wind field
8519 real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx, dyc
8520 real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy, dxc
8521 real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8522
8523 integer :: i,j,n
8524
8525 real :: tmp1i(isd:ied+1)
8526 real :: tmp2i(isd:ied+1)
8527 real :: tmp3i(isd:ied+1)
8528 real :: tmp1j(jsd:jed+1)
8529 real :: tmp2j(jsd:jed+1)
8530 real :: tmp3j(jsd:jed+1)
8531
8532 !CLEANUP: replace dxa with rdxa, and dya with rdya; may change numbers.
8533 #ifdef VORT_ON
8534 ! circulation (therefore, vort) conserving:
8535 do j=jsd,jed
8536 do i=isd,ied
8537 uout(i,j) = 0.5*(uin(i,j)*dx(i,j)+uin(i,j+1)*dx(i,j+1))/dxa(i,j)
8538 vout(i,j) = 0.5*(vin(i,j)*dy(i,j)+vin(i+1,j)*dy(i+1,j))/dya(i,j)
8539 enddo
8540 enddo
8541 #else
8542 do i=isd,ied
8543 tmp1j(:) = 0.0
8544 tmp2j(:) = uin(i,:)*dyc(i,:)
8545 tmp3j(:) = dyc(i,:)
8546 call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interpOrder)
8547 uout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dya(i,jsd:jed)
8548 enddo
8549 do j=jsd,jed
8550 tmp1i(:) = 0.0
8551 tmp2i(:) = vin(:,j)*dxc(:,j)
8552 tmp3i(:) = dxc(:,j)
8553 call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interpOrder)
8554 vout(isd:ied,j) = tmp1i(isd+1:ied+1)/dxa(isd:ied,j)
8555 enddo
8556 #endif
8557
8558 end subroutine dtoa
8559 !
8560 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8561 !-------------------------------------------------------------------------------
8562
8563 !-------------------------------------------------------------------------------
8564 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8565 subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, domain, noComm)
8566 integer, intent(IN) :: npx, npy, ng
8567 real , intent(IN) :: uin(isd:ied ,jsd:jed ) !< A-grid u-wind field
8568 real , intent(IN) :: vin(isd:ied ,jsd:jed ) !< A-grid v-wind field
8569 real , intent(OUT) :: uout(isd:ied+1,jsd:jed ) !< C-grid u-wind field
8570 real , intent(OUT) :: vout(isd:ied ,jsd:jed+1) !< C-grid v-wind field
8571 logical, intent(IN) :: nested
8572 logical, OPTIONAL, intent(IN) :: noComm
8573 real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx
8574 real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy
8575 real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8576 type(domain2d), intent(INOUT) :: domain
8577
8578 real :: ang1
8579 integer :: i,j,n
8580
8581 real :: tmp1i(isd:ied+1)
8582 real :: tmp2i(isd:ied)
8583 real :: tmp3i(isd:ied)
8584 real :: tmp1j(jsd:jed+1)
8585 real :: tmp2j(jsd:jed)
8586 real :: tmp3j(jsd:jed)
8587
8588 #if !defined(ALT_INTERP)
8589 #ifdef VORT_ON
8590 ! Circulation conserving
8591 do j=jsd,jed
8592 do i=isd+1,ied
8593 uout(i,j) = ( uin(i,j)*dxa(i,j) + uin(i-1,j)*dxa(i-1,j) ) &
8594 / ( dxa(i,j) + dxa(i-1,j) )
8595 enddo
8596 enddo
8597 do j=jsd+1,jed
8598 do i=isd,ied
8599 vout(i,j) = ( vin(i,j)*dya(i,j) + vin(i,j-1)*dya(i,j-1) ) &
8600 / ( dya(i,j) + dya(i,j-1) )
8601 enddo
8602 enddo
8603 #else
8604 do j=jsd,jed
8605 call interp_left_edge_1d(uout(:,j), uin(:,j), dxa(:,j), isd, ied, interpOrder)
8606 enddo
8607 do i=isd,ied
8608 !!$ tmp1j(:) = vout(i,:)
8609 tmp2j(:) = vin(i,:)
8610 tmp3j(:) = dya(i,:)
8611 call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder)
8612 vout(i,:) = tmp1j(:)
8613 enddo
8614 #endif
8615 #else
8616
8617 do j=jsd,jed
8618 !!$ tmp1i(:) = uout(:,j)
8619 tmp2i(:) = uin(:,j)*dya(:,j)
8620 tmp3i(:) = dxa(:,j)
8621 call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interpOrder)
8622 uout(:,j) = tmp1i(:)/dy(:,j)
8623 enddo
8624 do i=isd,ied
8625 !!$ tmp1j(:) = vout(i,:)
8626 tmp2j(:) = vin(i,:)*dxa(i,:)
8627 tmp3j(:) = dya(i,:)
8628 call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interpOrder)
8629 vout(i,:) = tmp1j(:)/dx(i,:)
8630 enddo
8631
8632 if (cubed_sphere .and. .not. nested) then
8633 csFac = COS(30.0*PI/180.0)
8634 ! apply Corner scale factor for interp on Cubed-Sphere
8635 if ( (is==1) .and. (js==1) ) then
8636 i=1
8637 j=1
8638 uout(i,j)=uout(i,j)*csFac
8639 uout(i,j-1)=uout(i,j-1)*csFac
8640 vout(i,j)=vout(i,j)*csFac
8641 vout(i-1,j)=vout(i-1,j)*csFac
8642 endif
8643 if ( (is==1) .and. (je==npy-1) ) then
8644 i=1
8645 j=npy-1
8646 uout(i,j)=uout(i,j)*csFac
8647 uout(i,j+1)=uout(i,j+1)*csFac
8648 vout(i,j+1)=vout(i,j+1)*csFac
8649 vout(i-1,j+1)=vout(i-1,j+1)*csFac
8650 endif
8651 if ( (ie==npx-1) .and. (je==npy-1) ) then
8652 i=npx-1
8653 j=npy-1
8654 uout(i+1,j)=uout(i+1,j)*csFac
8655 uout(i+1,j+1)=uout(i+1,j+1)*csFac
8656 vout(i,j+1)=vout(i,j+1)*csFac
8657 vout(i+1,j+1)=vout(i+1,j+1)*csFac
8658 endif
8659 if ( (ie==npx-1) .and. (js==1) ) then
8660 i=npx-1
8661 j=1
8662 uout(i+1,j)=uout(i+1,j)*csFac
8663 uout(i+1,j-1)=uout(i+1,j-1)*csFac
8664 vout(i,j)=vout(i,j)*csFac
8665 vout(i+1,j)=vout(i+1,j)*csFac
8666 endif
8667 endif
8668
8669 #endif
8670
8671 if (present(noComm)) then
8672 if (.not. noComm) call mpp_update_domains( uout,vout, domain, gridtype=CGRID_NE_PARAM, complete=.true.)
8673 else
8674 call mpp_update_domains( uout,vout, domain, gridtype=CGRID_NE_PARAM, complete=.true.)
8675 endif
8676 if (.not. nested) call fill_corners(uout, vout, npx, npy, VECTOR=.true., CGRID=.true.)
8677
8678 end subroutine atoc
8679 !
8680 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8681 !-------------------------------------------------------------------------------
8682
8683 !-------------------------------------------------------------------------------
8684 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8685 subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng)
8686 integer, intent(IN) :: npx, npy, ng
8687 real , intent(IN) :: uin(isd:ied+1,jsd:jed ) !< C-grid u-wind field
8688 real , intent(IN) :: vin(isd:ied ,jsd:jed+1) !< C-grid v-wind field
8689 real , intent(OUT) :: uout(isd:ied ,jsd:jed ) !< A-grid u-wind field
8690 real , intent(OUT) :: vout(isd:ied ,jsd:jed ) !< A-grid v-wind field
8691 real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc, dy
8692 real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc, dx
8693 real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8694
8695 integer :: i,j
8696
8697 real :: tmp1i(isd:ied+1)
8698 real :: tmp2i(isd:ied+1)
8699 real :: tmp3i(isd:ied+1)
8700 real :: tmp1j(jsd:jed+1)
8701 real :: tmp2j(jsd:jed+1)
8702 real :: tmp3j(jsd:jed+1)
8703
8704 ! do j=jsd,jed
8705 ! do i=isd,ied
8706 ! uout(i,j) = 0.5 * (uin(i,j)*dy(i,j) + uin(i+1,j)*dy(i+1,j))/dya(i,j)
8707 ! enddo
8708 ! enddo
8709 ! do j=jsd,jed
8710 ! do i=isd,ied
8711 ! vout(i,j) = 0.5 * (vin(i,j)*dx(i,j) + vin(i,j+1)*dx(i,j+1))/dxa(i,j)
8712 ! enddo
8713 ! enddo
8714 do i=isd,ied
8715 tmp1j(:) = 0.0
8716 tmp2j(:) = vin(i,:)*dx(i,:)
8717 tmp3j(:) = dyc(i,:)
8718 call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interpOrder)
8719 vout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dxa(i,jsd:jed)
8720 enddo
8721 do j=jsd,jed
8722 tmp1i(:) = 0.0
8723 tmp2i(:) = uin(:,j)*dy(:,j)
8724 tmp3i(:) = dxc(:,j)
8725 call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interpOrder)
8726 uout(isd:ied,j) = tmp1i(isd+1:ied+1)/dya(isd:ied,j)
8727 enddo
8728
8729 end subroutine ctoa
8730 !
8731 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8732 !-------------------------------------------------------------------------------
8733
8734 !-------------------------------------------------------------------------------
8735 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8736 subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)
8737 integer, intent(IN) :: ndims
8738 real , intent(INOUT) :: myU !< u-wind field
8739 real , intent(INOUT) :: myV !< v-wind field
8740 real(kind=R_GRID) , intent(IN) :: p1(ndims) ! p4
8741 real(kind=R_GRID) , intent(IN) :: p2(ndims) !
8742 real(kind=R_GRID) , intent(IN) :: p3(ndims) ! p1 t1 p3
8743 real(kind=R_GRID) , intent(IN) :: p4(ndims) !
8744 real(kind=R_GRID) , intent(IN) :: t1(ndims) ! p2
8745 integer, intent(IN) :: dir !< Direction ; 1=>sphere-to-cube 2=> cube-to-sphere
8746
8747 real(kind=R_GRID) :: ee1(3), ee2(3), ee3(3), elon(3), elat(3)
8748
8749 real :: g11, g12, g21, g22
8750
8751 real :: newu, newv
8752
8753 call get_unit_vector(p3, t1, p1, ee1)
8754 call get_unit_vector(p4, t1, p2, ee2)
8755 elon(1) = -SIN(t1(1) - pi)
8756 elon(2) = COS(t1(1) - pi)
8757 elon(3) = 0.0
8758 elat(1) = -SIN(t1(2))*COS(t1(1) - pi)
8759 elat(2) = -SIN(t1(2))*SIN(t1(1) - pi)
8760 elat(3) = COS(t1(2))
8761
8762 g11 = inner_prod(ee1,elon)
8763 g12 = inner_prod(ee1,elat)
8764 g21 = inner_prod(ee2,elon)
8765 g22 = inner_prod(ee2,elat)
8766
8767 if (dir == 1) then ! Sphere to Cube Rotation
8768 newu = myU*g11 + myV*g12
8769 newv = myU*g21 + myV*g22
8770 else
8771 newu = ( myU*g22 - myV*g12)/(g11*g22 - g21*g12)
8772 newv = (-myU*g21 + myV*g11)/(g11*g22 - g21*g12)
8773 endif
8774 myU = newu
8775 myV = newv
8776
8777 end subroutine rotate_winds
8778
8779 subroutine mp_update_dwinds_2d(u, v, npx, npy, domain)
8780 use mpp_parameter_mod, only: DGRID_NE
8781 real , intent(INOUT) :: u(isd:ied ,jsd:jed+1) !< D-grid u-wind field
8782 real , intent(INOUT) :: v(isd:ied+1,jsd:jed ) !< D-grid v-wind field
8783 integer, intent(IN) :: npx, npy
8784 type(domain2d), intent(INOUT) :: domain
8785
8786 call mpp_update_domains( u, v, domain, gridtype=DGRID_NE, complete=.true.)
8787 ! if (.not. nested) call fill_corners(u , v , npx, npy, VECTOR=.true., DGRID=.true.)
8788
8789 end subroutine mp_update_dwinds_2d
8790 !
8791 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8792 !-------------------------------------------------------------------------------
8793
8794 !-------------------------------------------------------------------------------
8795 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8796 !
8797 subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain)
8798 use mpp_parameter_mod, only: DGRID_NE
8799 real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) !< D-grid u-wind field
8800 real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) !< D-grid v-wind field
8801 integer, intent(IN) :: npx, npy, npz
8802 type(domain2d), intent(INOUT) :: domain
8803 integer k
8804
8805 call mpp_update_domains( u, v, domain, gridtype=DGRID_NE, complete=.true.)
8806 ! do k=1,npz
8807 ! if (.not. nested) call fill_corners(u(isd:,jsd:,k) , v(isd:,jsd:,k) , npx, npy, VECTOR=.true., DGRID=.true.)
8808 ! enddo
8809
8810 end subroutine mp_update_dwinds_3d
8811
8812 !-------------------------------------------------------------------------------
8813 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8814 real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile) result (gsum)
8815 integer, intent(IN) :: npx, npy
8816 integer, intent(IN) :: ifirst, ilast
8817 integer, intent(IN) :: jfirst, jlast
8818 integer, intent(IN) :: isd, ied
8819 integer, intent(IN) :: jsd, jed, tile
8820 real , intent(IN) :: p(ifirst:ilast,jfirst:jlast) !< field to be summed
8821 type(fv_grid_type), intent(IN), target :: gridstruct
8822
8823 integer :: i,j,k,n
8824 integer :: j1, j2
8825 real :: gsum0
8826 real, allocatable :: p_R8(:,:,:)
8827
8828 real, pointer, dimension(:,:,:) :: agrid, grid
8829 real, pointer, dimension(:,:) :: area, rarea, fC, f0
8830 real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8831
8832 logical, pointer :: cubed_sphere, latlon
8833
8834 logical, pointer :: have_south_pole, have_north_pole
8835
8836 integer, pointer :: ntiles_g
8837 real, pointer :: acapN, acapS, globalarea
8838
8839 grid => gridstruct%grid
8840 agrid=> gridstruct%agrid
8841
8842 area => gridstruct%area
8843 rarea => gridstruct%rarea
8844
8845 fC => gridstruct%fC
8846 f0 => gridstruct%f0
8847
8848 dx => gridstruct%dx
8849 dy => gridstruct%dy
8850 dxa => gridstruct%dxa
8851 dya => gridstruct%dya
8852 rdxa => gridstruct%rdxa
8853 rdya => gridstruct%rdya
8854 dxc => gridstruct%dxc
8855 dyc => gridstruct%dyc
8856
8857 cubed_sphere => gridstruct%cubed_sphere
8858 latlon => gridstruct%latlon
8859
8860 have_south_pole => gridstruct%have_south_pole
8861 have_north_pole => gridstruct%have_north_pole
8862
8863 ntiles_g => gridstruct%ntiles_g
8864 acapN => gridstruct%acapN
8865 acapS => gridstruct%acapS
8866 globalarea => gridstruct%globalarea
8867
8868 allocate(p_r8(npx-1,npy-1,ntiles_g))
8869 gsum = 0.
8870
8871 if (latlon) then
8872 j1 = 2
8873 j2 = npy-2
8874 !!! WARNING: acapS and acapN have NOT been initialized.
8875 gsum = gsum + p(1,1)*acapS
8876 gsum = gsum + p(1,npy-1)*acapN
8877 do j=j1,j2
8878 do i=1,npx-1
8879 gsum = gsum + p(i,j)*cos(agrid(i,j,2))
8880 enddo
8881 enddo
8882 else
8883
8884 do n=tile,tile
8885 do j=jfirst,jlast
8886 do i=ifirst,ilast
8887 p_R8(i,j,n) = p(i,j)*area(i,j)
8888 enddo
8889 enddo
8890 enddo
8891 call mp_gather(p_R8, ifirst,ilast, jfirst,jlast, npx-1, npy-1, ntiles_g)
8892 if (is_master()) then
8893 do n=1,ntiles_g
8894 do j=1,npy-1
8895 do i=1,npx-1
8896 gsum = gsum + p_R8(i,j,n)
8897 enddo
8898 enddo
8899 enddo
8900 gsum = gsum/globalarea
8901 endif
8902 call mpp_broadcast(gsum, mpp_root_pe())
8903
8904 endif
8905
8906 deallocate(p_r8)
8907
8908 end function globalsum
8909
8910
8911 subroutine get_unit_vector( p1, p2, p3, uvect )
8912 real(kind=R_GRID), intent(in):: p1(2), p2(2), p3(2) ! input position unit vectors (spherical coordinates)
8913 real(kind=R_GRID), intent(out):: uvect(3) ! output unit spherical cartesian
8914 ! local
8915 integer :: n
8916 real(kind=R_GRID) :: xyz1(3), xyz2(3), xyz3(3)
8917 real :: dp(3)
8918
8919 call spherical_to_cartesian(p1(1), p1(2), one, xyz1(1), xyz1(2), xyz1(3))
8920 call spherical_to_cartesian(p2(1), p2(2), one, xyz2(1), xyz2(2), xyz2(3))
8921 call spherical_to_cartesian(p3(1), p3(2), one, xyz3(1), xyz3(2), xyz3(3))
8922 do n=1,3
8923 uvect(n) = xyz3(n)-xyz1(n)
8924 enddo
8925 call project_sphere_v(1, uvect,xyz2)
8926 call normalize_vect(1, uvect)
8927
8928 end subroutine get_unit_vector
8929
8930
8931 subroutine normalize_vect(np, e)
8932 !
8933 ! Make e an unit vector
8934 !
8935 implicit none
8936 integer, intent(in):: np
8937 real(kind=R_GRID), intent(inout):: e(3,np)
8938 ! local:
8939 integer k, n
8940 real pdot
8941
8942 do n=1,np
8943 pdot = sqrt(e(1,n)**2+e(2,n)**2+e(3,n)**2)
8944 do k=1,3
8945 e(k,n) = e(k,n) / pdot
8946 enddo
8947 enddo
8948
8949 end subroutine normalize_vect
8950 !------------------------------------------------------------------------------
8951 !BOP
8952 ! !ROUTINE: mp_ghost_ew --- Ghost 4d east/west "lat/lon periodic
8953 !
8954 ! !INTERFACE:
8955 subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, &
8956 kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
8957 !
8958 ! !INPUT PARAMETERS:
8959 integer, intent(in):: im, jm, km, nq
8960 integer, intent(in):: ifirst, ilast
8961 integer, intent(in):: jfirst, jlast
8962 integer, intent(in):: kfirst, klast
8963 integer, intent(in):: ng_e ! eastern zones to ghost
8964 integer, intent(in):: ng_w ! western zones to ghost
8965 integer, intent(in):: ng_s ! southern zones to ghost
8966 integer, intent(in):: ng_n ! northern zones to ghost
8967 real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
8968 real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq)
8969 !
8970 ! !DESCRIPTION:
8971 !
8972 ! Ghost 4d east/west
8973 !
8974 ! !REVISION HISTORY:
8975 ! 2005.08.22 Putman
8976 !
8977 !EOP
8978 !------------------------------------------------------------------------------
8979 !BOC
8980 integer :: i,j,k,n
8981
8982 if (present(q)) then
8983 q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = &
8984 q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq)
8985 endif
8986
8987 ! Assume Periodicity in X-dir and not overlapping
8988 do n=1,nq
8989 do k=kfirst,klast
8990 do j=jfirst-ng_s,jlast+ng_n
8991 do i=1, ng_w
8992 q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n)
8993 enddo
8994 do i=1, ng_e
8995 q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n)
8996 enddo
8997 enddo
8998 enddo
8999 enddo
9000
9001 !EOC
9002 end subroutine mp_ghost_ew
9003
9004
9005
9006
9007
9008
9009 !-------------------------------------------------------------------------------
9010 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
9011 subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
9012 integer, intent(in):: ifirst,ilast
9013 real, intent(out) :: qout(ifirst:)
9014 real, intent(in) :: qin(ifirst:)
9015 real, intent(in) :: dx(ifirst:)
9016 integer, intent(in):: order
9017 integer :: i
9018
9019 real :: dm(ifirst:ilast),qmax,qmin
9020 real :: r3, da1, da2, a6da, a6, al, ar
9021 real :: qLa, qLb1, qLb2
9022 real :: x
9023
9024 r3 = 1./3.
9025
9026 qout(:) = 0.0
9027 if (order==1) then
9028 ! 1st order Uniform linear averaging
9029 do i=ifirst+1,ilast
9030 qout(i) = 0.5 * (qin(i-1) + qin(i))
9031 enddo
9032 elseif (order==2) then
9033 ! Non-Uniform 1st order average
9034 do i=ifirst+1,ilast
9035 qout(i) = (dx(i-1)*qin(i-1) + dx(i)*qin(i))/(dx(i-1)+dx(i))
9036 enddo
9037 elseif (order==3) then
9038
9039 ! PPM - Uniform
9040 do i=ifirst+1,ilast-1
9041 dm(i) = 0.25*(qin(i+1) - qin(i-1))
9042 enddo
9043 !
9044 ! Applies monotonic slope constraint
9045 !
9046 do i=ifirst+1,ilast-1
9047 qmax = max(qin(i-1),qin(i),qin(i+1)) - qin(i)
9048 qmin = qin(i) - min(qin(i-1),qin(i),qin(i+1))
9049 dm(i) = sign(min(abs(dm(i)),qmin,qmax),dm(i))
9050 enddo
9051
9052 do i=ifirst+1,ilast-1
9053 qout(i) = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9054 ! al = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9055 ! da1 = dm(i) + dm(i)
9056 ! qout(i) = qin(i) - sign(min(abs(da1),abs(al-qin(i))), da1)
9057 enddo
9058
9059 ! First order average to fill in end points
9060 qout(ifirst+1) = 0.5 * (qin(ifirst) + qin(ifirst+1))
9061 qout(ilast) = 0.5 * (qin(ilast-1) + qin(ilast))
9062
9063 elseif (order==4) then
9064
9065 ! Non-Uniform PPM
9066 do i=ifirst+1,ilast-1
9067 dm(i) = ( (2.*dx(i-1) + dx(i) ) / &
9068 ( dx(i+1) + dx(i) ) ) * ( qin(i+1) - qin(i) ) + &
9069 ( (dx(i) + 2.*dx(i+1)) / &
9070 (dx(i-1) + dx(i) ) ) * ( qin(i) - qin(i-1) )
9071 dm(i) = ( dx(i) / ( dx(i-1) + dx(i) + dx(i+1) ) ) * dm(i)
9072 if ( (qin(i+1)-qin(i))*(qin(i)-qin(i-1)) > 0.) then
9073 dm(i) = SIGN( MIN( ABS(dm(i)), 2.*ABS(qin(i)-qin(i-1)), 2.*ABS(qin(i+1)-qin(i)) ) , dm(i) )
9074 else
9075 dm(i) = 0.
9076 endif
9077 enddo
9078
9079 do i=ifirst+2,ilast-1
9080 qLa = ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) - &
9081 ( (dx(i+1) + dx(i)) / (2.*dx(i) + dx(i-1)) )
9082 qLa = ( (2.*dx(i) * dx(i-1)) / (dx(i-1) + dx(i)) ) * qLa * &
9083 (qin(i) - qin(i-1))
9084 qLb1 = dx(i-1) * ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) * &
9085 dm(i)
9086 qLb2 = dx(i) * ( (dx(i) + dx(i+1)) / (dx(i-1) + 2.*dx(i)) ) * &
9087 dm(i-1)
9088
9089 qout(i) = 1. / ( dx(i-2) + dx(i-1) + dx(i) + dx(i+1) )
9090 qout(i) = qout(i) * ( qLa - qLb1 + qLb2 )
9091 qout(i) = qin(i-1) + ( dx(i-1) / ( dx(i-1) + dx(i) ) ) * (qin(i) - qin(i-1)) + qout(i)
9092 enddo
9093
9094 elseif (order==5) then
9095
9096 ! Linear Spline
9097 do i=ifirst+1,ilast-1
9098 x = FLOAT(i-(ifirst+1))*FLOAT(ilast-ifirst+1-1)/FLOAT(ilast-ifirst-1)
9099 qout(i) = qin(ifirst+NINT(x)) + (x - NINT(x)) * (qin(ifirst+NINT(x+1)) - qin(ifirst+NINT(x)))
9100 ! if (tile==1) print*, ifirst+NINT(x+1), ifirst+NINT(x), (x - NINT(x))
9101 ! if (tile==1) print*, 0.5*(qin(i-1)+qin(i)), qout(i)
9102 enddo
9103
9104 !!$ if (tile==1) print*,'x=fltarr(28)'
9105 !!$ do i=ifirst,ilast
9106 !!$ if (tile==1) print*, 'x(',i-ifirst,')=',qin(i)
9107 !!$ enddo
9108
9109
9110 call mp_stop
9111 stop
9112
9113 endif
9114
9115 end subroutine interp_left_edge_1d
9116 !------------------------------------------------------------------------------
9117 !-----------------------------------------------------------------------
9118 subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, &
9119 ng_d, ng_s, jfirst, jlast)
9120 ! !INPUT PARAMETERS:
9121 integer im !< Total longitudes
9122 integer jm !< Total latitudes
9123 integer jfirst !< First PE latitude (no ghosting)
9124 integer jlast !< Last PE latitude (no ghosting)
9125 integer, intent(in):: ng_s, ng_d
9126 real, intent(in):: coslon(im,jm), sinlon(im,jm)
9127 real, intent(in):: cosl5(im,jm),sinl5(im,jm)
9128 real, intent(in):: u(im,jfirst-ng_d:jlast+ng_s)
9129
9130 ! !INPUT/OUTPUT PARAMETERS:
9131 real, intent(inout):: v(im,jfirst-ng_d:jlast+ng_d)
9132
9133 ! !LOCAL VARIABLES:
9134
9135 integer i, imh
9136 real uanp(im), uasp(im), vanp(im), vasp(im)
9137 real un, vn, us, vs, r2im
9138
9139 ! WS 99.05.25 : Replaced conversions of IMR with IM
9140 r2im = 0.5d0/dble(im)
9141 imh = im / 2
9142
9143 ! WS 990726 : Added condition to decide if poles are on this processor
9144
9145 if ( jfirst-ng_d <= 1 ) then
9146 do i=1,im
9147 uasp(i) = u(i, 2) + u(i,3)
9148 enddo
9149
9150 do i=1,im-1
9151 vasp(i) = v(i, 2) + v(i+1,2)
9152 enddo
9153 vasp(im) = v(im,2) + v(1,2)
9154
9155 ! Projection at SP
9156 us = 0.; vs = 0.
9157
9158 do i=1,imh
9159 us = us + (uasp(i+imh)-uasp(i))*sinlon(i,1) &
9160 + (vasp(i)-vasp(i+imh))*coslon(i,1)
9161 vs = vs + (uasp(i+imh)-uasp(i))*coslon(i,1) &
9162 + (vasp(i+imh)-vasp(i))*sinlon(i,1)
9163 enddo
9164 us = us*r2im
9165 vs = vs*r2im
9166
9167 ! get V-wind at SP
9168
9169 do i=1,imh
9170 v(i, 1) = us*cosl5(i,1) - vs*sinl5(i,1)
9171 v(i+imh,1) = -v(i,1)
9172 enddo
9173
9174 endif
9175
9176 if ( jlast+ng_d >= jm ) then
9177
9178 do i=1,im
9179 uanp(i) = u(i,jm-1) + u(i,jm)
9180 enddo
9181
9182 do i=1,im-1
9183 vanp(i) = v(i,jm-1) + v(i+1,jm-1)
9184 enddo
9185 vanp(im) = v(im,jm-1) + v(1,jm-1)
9186
9187 ! Projection at NP
9188
9189 un = 0.
9190 vn = 0.
9191 do i=1,imh
9192 un = un + (uanp(i+imh)-uanp(i))*sinlon(i,jm) &
9193 + (vanp(i+imh)-vanp(i))*coslon(i,jm)
9194 vn = vn + (uanp(i)-uanp(i+imh))*coslon(i,jm) &
9195 + (vanp(i+imh)-vanp(i))*sinlon(i,jm)
9196 enddo
9197 un = un*r2im
9198 vn = vn*r2im
9199
9200 ! get V-wind at NP
9201
9202 do i=1,imh
9203 v(i, jm) = -un*cosl5(i,jm) - vn*sinl5(i,jm)
9204 v(i+imh,jm) = -v(i,jm)
9205 enddo
9206
9207 endif
9208
9209 end subroutine vpol5
9210
9211 subroutine prt_m1(qname, q, is, ie, js, je, n_g, km, fac)
9212 ! Single PE version
9213 character(len=*), intent(in):: qname
9214 integer, intent(in):: is, ie, js, je
9215 integer, intent(in):: n_g, km
9216 real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
9217 real, intent(in):: fac
9218
9219 real qmin, qmax
9220 integer i,j,k
9221
9222 qmin = q(is,js,1)
9223 qmax = qmin
9224
9225 do k=1,km
9226 do j=js,je
9227 do i=is,ie
9228 if( q(i,j,k) < qmin ) then
9229 qmin = q(i,j,k)
9230 elseif( q(i,j,k) > qmax ) then
9231 qmax = q(i,j,k)
9232 endif
9233 enddo
9234 enddo
9235 enddo
9236
9237 write(*,*) qname, ' max = ', qmax*fac, ' min = ', qmin*fac
9238
9239 end subroutine prt_m1
9240
9241 subroutine var_dz(km, ztop, ze)
9242 integer, intent(in):: km
9243 real, intent(in):: ztop
9244 real, intent(out), dimension(km+1):: ze
9245 ! Local
9246 real, dimension(km):: dz, s_fac
9247 real dz0, sum1
9248 integer k
9249
9250 s_fac(km ) = 0.25
9251 s_fac(km-1) = 0.30
9252 s_fac(km-2) = 0.50
9253 s_fac(km-3) = 0.70
9254 s_fac(km-4) = 0.90
9255 s_fac(km-5) = 1.
9256 do k=km-6, 5, -1
9257 s_fac(k) = 1.05 * s_fac(k+1)
9258 enddo
9259 s_fac(4) = 1.1*s_fac(5)
9260 s_fac(3) = 1.2*s_fac(4)
9261 s_fac(2) = 1.3*s_fac(3)
9262 s_fac(1) = 1.5*s_fac(2)
9263
9264 sum1 = 0.
9265 do k=1,km
9266 sum1 = sum1 + s_fac(k)
9267 enddo
9268
9269 dz0 = ztop / sum1
9270
9271 do k=1,km
9272 dz(k) = s_fac(k) * dz0
9273 enddo
9274
9275 ze(km+1) = 0.
9276 do k=km,1,-1
9277 ze(k) = ze(k+1) + dz(k)
9278 enddo
9279
9280 ! Re-scale dz with the stretched ztop
9281 do k=1,km
9282 dz(k) = dz(k) * (ztop/ze(1))
9283 enddo
9284
9285 do k=km,1,-1
9286 ze(k) = ze(k+1) + dz(k)
9287 enddo
9288 ze(1) = ztop
9289
9290 call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 1)
9291
9292 if ( is_master() ) then
9293 write(*,*) 'var_dz: model top (km)=', ztop*0.001
9294 do k=km,1,-1
9295 dz(k) = ze(k) - ze(k+1)
9296 write(*,*) k, 0.5*(ze(k)+ze(k+1)), 'dz=', dz(k)
9297 enddo
9298 endif
9299
9300 end subroutine var_dz
9301
9302 subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
9303 integer, intent(in):: is, ie, js, je, km
9304 integer, intent(in):: ntimes, i, j
9305 real, intent(inout):: ze(is:ie,js:je,km+1)
9306 ! local:
9307 real, parameter:: df = 0.25
9308 real dz(km)
9309 real flux(km+1)
9310 integer k, n, k1, k2
9311
9312 k2 = km-1
9313 do k=1,km
9314 dz(k) = ze(i,j,k+1) - ze(i,j,k)
9315 enddo
9316
9317 do n=1,ntimes
9318 k1 = 2 + (ntimes-n)
9319
9320 flux(k1 ) = 0.
9321 flux(k2+1) = 0.
9322 do k=k1+1,k2
9323 flux(k) = df*(dz(k) - dz(k-1))
9324 enddo
9325
9326 do k=k1,k2
9327 dz(k) = dz(k) - flux(k) + flux(k+1)
9328 enddo
9329 enddo
9330
9331 do k=km,1,-1
9332 ze(i,j,k) = ze(i,j,k+1) - dz(k)
9333 enddo
9334
9335 end subroutine sm1_edge
9336
9337
9338
9339 end module test_cases_mod
9340